← Back to branch summary

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

« back to all changes in this revision

Viewing changes to fpcsrc/rtl/macos/system.pp

  • 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/rtl/macos/system.pp
 
1
{
 
2
    This file is part of the Free Pascal run time library.
 
3
    Copyright (c) 2002-2004 by Olle Raab
 
4
 
 
5
    FreePascal system unit for MacOS.
 
6
 
 
7
    See the file COPYING.FPC, included in this distribution,
 
8
    for details about the copyright.
 
9
 
 
10
    This program is distributed in the hope that it will be useful,
 
11
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
13
 
 
14
 **********************************************************************}
 
15
unit System;
 
16
 
 
17
interface
 
18
 
 
19
{ include system-independent routine headers }
 
20
{$I systemh.inc}
 
21
 
 
22
const
 
23
 LineEnding = #13;
 
24
 LFNSupport = true;
 
25
 DirectorySeparator = ':';
 
26
 DriveSeparator = ':';
 
27
 PathSeparator = ',';  {Is used in MPW and OzTeX}
 
28
 FileNameCaseSensitive = false;
 
29
 CtrlZMarksEOF: boolean = false; (* #26 not considered as end of file *)
 
30
  
 
31
 maxExitCode = 65535;
 
32
 MaxPathLen = 256;
 
33
  
 
34
const
 
35
{ Default filehandles }
 
36
  UnusedHandle    : Longint = -1;
 
37
  StdInputHandle  : Longint = 0;
 
38
  StdOutputHandle : Longint = 1;
 
39
  StdErrorHandle  : Longint = 2;
 
40
 
 
41
  sLineBreak = LineEnding;
 
42
  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCR;
 
43
 
 
44
 
 
45
 
 
46
var
 
47
  argc : longint;
 
48
  argv : ppchar;
 
49
  envp : ppchar;
 
50
 
 
51
{*********************************}
 
52
{**  MacOS specific functions    **}
 
53
{*********************************}
 
54
 
 
55
{To be called at regular intervals, for lenghty tasks.
 
56
 Yield might give time for other tasks to run under the cooperative
 
57
 multitasked macos. For an MPW Tool, it also spinns the cursor.}
 
58
 
 
59
procedure Yield;
 
60
 
 
61
{To set mac file type and creator codes, to be used for files created
 
62
 by the FPC runtime library. They must be exactly 4 chars long.}
 
63
 
 
64
procedure SetDefaultMacOSFiletype(ftype: ShortString);
 
65
procedure SetDefaultMacOSCreator(creator: ShortString);
 
66
 
 
67
var
 
68
  {Whether unix and dos style paths should be translated. Default false}
 
69
  pathTranslation: Boolean;
 
70
 
 
71
 
 
72
{*********************************}
 
73
{**  Available features on macos **}
 
74
{*********************************}
 
75
 
 
76
 
 
77
  var
 
78
    macosHasGestalt: Boolean;
 
79
    macosHasWaitNextEvent: Boolean;
 
80
    macosHasColorQD: Boolean;
 
81
    macosHasFPU: Boolean;
 
82
    macosSystemVersion: Integer;
 
83
    macosHasSysDebugger: Boolean = false;
 
84
    macosHasCFM: Boolean;
 
85
 
 
86
    macosHasAppleEvents: Boolean;
 
87
    macosHasAliasMgr: Boolean;
 
88
 
 
89
 
 
90
    macosHasFSSpec: Boolean;
 
91
    macosHasFindFolder: Boolean;
 
92
 
 
93
 
 
94
    macosHasScriptMgr: Boolean;
 
95
    macosNrOfScriptsInstalled: Integer;
 
96
 
 
97
    macosHasAppearance: Boolean;
 
98
    macosHasAppearance101: Boolean;
 
99
    macosHasAppearance11: Boolean;
 
100
 
 
101
    macosBootVolumeVRefNum: Integer;
 
102
    macosBootVolumeName: String[31];
 
103
 
 
104
{
 
105
 MacOS paths
 
106
 ===========
 
107
 MacOS directory separator is a colon ":" which is the only character not
 
108
 allowed in filenames.
 
109
 A path containing no colon or which begins with a colon is a partial path.
 
110
 E g ":kalle:petter" ":kalle" "kalle"
 
111
 All other paths are full (absolute) paths. E g "HD:kalle:" "HD:"
 
112
 When generating paths, one is safe is one ensures that all partial paths
 
113
 begins with a colon, and all full paths ends with a colon.
 
114
 In full paths the first name (e g HD above) is the name of a mounted volume.
 
115
 These names are not unique, because, for instance, two diskettes with the
 
116
 same names could be inserted. This means that paths on MacOS is not
 
117
 waterproof. In case of equal names the first volume found will do.
 
118
 Two colons "::" are the relative path to the parent. Three is to the
 
119
 grandparent etc.
 
120
}
 
121
 
 
122
implementation
 
123
 
 
124
{
 
125
About the implementation
 
126
========================
 
127
A MacOS application is assembled and linked by MPW (Macintosh
 
128
Programmers Workshop), which nowadays is free to use. For info
 
129
and download of MPW and MacOS api, see www.apple.com
 
130
 
 
131
It can be linked to either a graphical user interface application,
 
132
a standalone text only application (using SIOW) or
 
133
to an MPW tool, this is entirely controlled by the linking step.
 
134
 
 
135
It requires system 7 and CFM, which is always the case for PowerPC.
 
136
 
 
137
If a m68k version would be implemented, it would save a lot
 
138
of efforts if it also uses CFM. This System.pp should, with
 
139
minor modifications, probably work with m68k.
 
140
 
 
141
Initial working directory is the directory of the application,
 
142
or for an MPWTool, the working directory as set by the
 
143
Directory command in MPW.
 
144
 
 
145
Note about working directory. There is a facility in MacOS which
 
146
manages a working directory for an application, initially set to
 
147
the applications directory, or for an MPWTool, the tool's directory.
 
148
However, this requires the application to have a unique application
 
149
signature (creator code), to distinguish its working directory
 
150
from working directories of other applications. Due to the fact
 
151
that casual applications are anonymous in this sense (without an
 
152
application signature), this facility will not work. Also, this
 
153
working directory facility is not present in Carbon. Hence we
 
154
will manage a working directory by our self.
 
155
 
 
156
 
 
157
Deviations
 
158
==========
 
159
 
 
160
In current implementation, working directory is stored as
 
161
directory id. This means there is a possibility the user moves the
 
162
working directory or a parent to it, while the application uses it.
 
163
Then the path to the wd suddenly changes. This is AFAIK not in
 
164
accordance with other OS's. Although this is a minor caveat,
 
165
it is mentioned here. To overcome this the wd could be stored
 
166
as a path instead, but this imposes translations from fullpath
 
167
to directory ID each time the filesystem is accessed.
 
168
 
 
169
The initial working directory for an MPWTool, as considered by
 
170
FPC, is different from the MacOS working directory facility,
 
171
see above.
 
172
 
 
173
 
 
174
Possible improvements:
 
175
=====================
 
176
 
 
177
Perhaps handle readonly filesystems, as in sysunix.inc
 
178
 
 
179
}
 
180
 
 
181
{******** include system independent routines **********}
 
182
{$I system.inc}
 
183
 
 
184
 
 
185
{*****************************************************************************
 
186
                              ParamStr/Randomize
 
187
*****************************************************************************}
 
188
 
 
189
{ number of args }
 
190
function paramcount : longint;
 
191
begin
 
192
  paramcount := argc - 1;
 
193
  //paramcount:=0;
 
194
end;
 
195
 
 
196
{ argument number l }
 
197
function paramstr(l : longint) : string;
 
198
begin
 
199
  if (l>=0) and (l+1<=argc) then
 
200
    paramstr:=strpas(argv[l])
 
201
  else
 
202
    paramstr:='';
 
203
end;
 
204
 
 
205
{ set randseed to a new pseudo random value }
 
206
procedure randomize;
 
207
begin
 
208
  randseed:= Cardinal(TickCount);
 
209
end;
 
210
 
 
211
 
 
212
{*****************************************************************************
 
213
                         SystemUnit Initialization
 
214
*****************************************************************************}
 
215
 
 
216
{$ifndef FPC_DARWIN_PASCALMAIN}
 
217
procedure pascalmain; external name 'PASCALMAIN';
 
218
 
 
219
{Main entry point in C style, needed to capture program parameters.
 
220
 For this to work, the system unit must be before the main program
 
221
 in the linking order.}
 
222
procedure main(argcparam: Longint; argvparam: ppchar; envpparam: ppchar); cdecl; [public];
 
223
{$else FPC_DARWIN_PASCALMAIN}
 
224
procedure FPC_SYSTEMMAIN(argcparam: Longint; argvparam: ppchar; envpparam: ppchar); cdecl; [public];
 
225
{$endif FPC_DARWIN_PASCALMAIN}
 
226
 
 
227
begin
 
228
  argc:= argcparam;
 
229
  argv:= argvparam;
 
230
  envp:= envpparam;
 
231
{$ifndef FPC_DARWIN_PASCALMAIN}
 
232
  pascalmain;  {run the pascal main program}
 
233
{$endif FPC_DARWIN_PASCALMAIN}
 
234
end;
 
235
 
 
236
procedure setup_arguments;
 
237
         begin
 
238
           {Nothing needs to be done here.}
 
239
         end;
 
240
 
 
241
procedure setup_environment;
 
242
         begin
 
243
         end;
 
244
 
 
245
 
 
246
{ FindSysFolder returns the (real) vRefNum, and the DirID of the current
 
247
system folder. It uses the Folder Manager if present, otherwise it falls
 
248
back to SysEnvirons. It returns zero on success, otherwise a standard
 
249
system error. }
 
250
 
 
251
function FindSysFolder(var foundVRefNum: Integer; var foundDirID: Longint): OSErr;
 
252
 
 
253
var
 
254
  gesResponse: Longint;
 
255
  envRec: SysEnvRec;
 
256
  myWDPB: WDPBRec;
 
257
  volName: String[34];
 
258
  err: OSErr;
 
259
 
 
260
begin
 
261
  foundVRefNum := 0;
 
262
  foundDirID := 0;
 
263
  if  macosHasGestalt
 
264
      and (Gestalt (FourCharCodeToLongword(gestaltFindFolderAttr), gesResponse) = noErr)
 
265
      and BitIsSet (gesResponse, gestaltFindFolderPresent) then
 
266
    begin { Does Folder Manager exist? }
 
267
       err := FindFolder (kOnSystemDisk, FourCharCodeToLongword(kSystemFolderType),
 
268
        kDontCreateFolder, foundVRefNum, foundDirID);
 
269
    end
 
270
  else
 
271
    begin
 
272
      { Gestalt can't give us the answer, so we resort to SysEnvirons }
 
273
      err := SysEnvirons (curSysEnvVers, envRec);
 
274
      if (err = noErr) then
 
275
        begin
 
276
          myWDPB.ioVRefNum := envRec.sysVRefNum;
 
277
          volName := '';
 
278
          myWDPB.ioNamePtr := @volName;
 
279
          myWDPB.ioWDIndex := 0;
 
280
          myWDPB.ioWDProcID := 0;
 
281
          err := PBGetWDInfoSync (@myWDPB);
 
282
          if (err = noErr) then
 
283
            begin
 
284
              foundVRefNum := myWDPB.ioWDVRefNum;
 
285
              foundDirID := myWDPB.ioWDDirID;
 
286
            end;
 
287
          end;
 
288
        end;
 
289
  FindSysFolder:= err;
 
290
end;
 
291
 
 
292
procedure InvestigateSystem;
 
293
 
 
294
  {$IFDEF CPUM68K}
 
295
  const
 
296
    _GestaltDispatch = $A0AD;
 
297
    _WaitNextEvent = $A860;
 
298
    _ScriptUtil = $A8B5;
 
299
 
 
300
    qdOffscreenTrap = $AB1D;
 
301
  {$ENDIF}
 
302
 
 
303
  var
 
304
    err: Integer;
 
305
    response: Longint;
 
306
    {$IFDEF CPUM68K}
 
307
    environs: SysEnvRec;
 
308
    {$ENDIF}
 
309
 
 
310
  {Vi r�knar med att man k�r p� minst system 6.0.5.  D� finns b�de Gestalt och GDevice med.}
 
311
  {Enligt Change Histrory �r MacOS 6.0.5 mera konsistent mellan maskinmodellerna �n f�reg�ende system}
 
312
 
 
313
begin
 
314
  {$IFDEF CPUM68K}
 
315
  macosHasGestalt := TrapAvailable(_GestaltDispatch);
 
316
  {$ELSE}
 
317
  macosHasGestalt := true;  {There is always Gestalt on PowerPC}
 
318
  {$ENDIF}
 
319
 
 
320
  if not macosHasGestalt then    (* If we don't have Gestalt, then we can't have any System 7 features  *)
 
321
    begin
 
322
      {$IFDEF CPUM68K}
 
323
      {      Detta kan endast g�lla p� en 68K maskin.}
 
324
      macosHasScriptMgr := TrapAvailable(_ScriptUtil);
 
325
 
 
326
      macosNrOfScriptsInstalled := 1; (* assume only Roman script, to start with  *)
 
327
 
 
328
      err := SysEnvirons(1, environs);
 
329
      if err = noErr then
 
330
        begin
 
331
          if environs.machineType < 0 then       { gammalt ROM}
 
332
            macosHasWaitNextEvent := FALSE
 
333
          else
 
334
            macosHasWaitNextEvent := TrapAvailable(_WaitNextEvent);
 
335
          macosHasColorQD := environs.hasColorQD;
 
336
          macosHasFPU := environs.hasFPU;
 
337
          macosSystemVersion := environs.systemVersion;
 
338
        end
 
339
      else
 
340
        begin
 
341
          macosHasWaitNextEvent := FALSE;
 
342
          macosHasColorQD := FALSE;
 
343
          macosHasFPU := FALSE;
 
344
          macosSystemVersion := 0;
 
345
        end;
 
346
 
 
347
      macosHasSysDebugger := (LongintPtr(MacJmp)^ <> 0);
 
348
 
 
349
      macosHasCFM := false;
 
350
      macosHasAppleEvents := false;
 
351
      macosHasAliasMgr := false;
 
352
 
 
353
      macosHasFSSpec := false;
 
354
      macosHasFindFolder := false;
 
355
 
 
356
      macosHasAppearance := false;
 
357
      macosHasAppearance101 := false;
 
358
      macosHasAppearance11 := false;
 
359
      {$IFDEF THINK_PASCAL}
 
360
      if (macosHasScriptMgr) then
 
361
        macosNrOfScriptsInstalled := GetEnvirons(smEnabled);
 
362
      {$ELSE}
 
363
      if (macosHasScriptMgr) then
 
364
        macosNrOfScriptsInstalled := GetScriptManagerVariable(smEnabled);  {Gamla rutinnamnet var GetEnvirons.}
 
365
      {$ENDIF}
 
366
      {$ENDIF}
 
367
    end
 
368
  else
 
369
    begin
 
370
      macosHasScriptMgr := Gestalt(FourCharCodeToLongword(gestaltScriptMgrVersion), response) = noErr;  {F�r att ta reda p� om script mgr finns.}
 
371
      macosNrOfScriptsInstalled := 1; (* assume only Roman script, to start with  *)
 
372
      macosHasWaitNextEvent := true;
 
373
 
 
374
      if Gestalt(FourCharCodeToLongword(gestaltSystemVersion), response) = noErr then
 
375
        macosSystemVersion := response
 
376
      else
 
377
        macosSystemVersion := 0;  {Borde inte kunna h�nda.}
 
378
 
 
379
      if Gestalt(FourCharCodeToLongword(gestaltOSAttr), response) = noErr then
 
380
        macosHasSysDebugger := BitIsSet(response, gestaltSysDebuggerSupport)
 
381
      else
 
382
        macosHasSysDebugger := false;
 
383
 
 
384
      if Gestalt(FourCharCodeToLongword(gestaltQuickdrawVersion), response) = noErr then
 
385
        macosHasColorQD := (response >= $0100)
 
386
      else
 
387
        macosHasColorQD := false;
 
388
 
 
389
      if Gestalt(FourCharCodeToLongword(gestaltFPUType), response) = noErr then
 
390
        macosHasFPU := (response <> gestaltNoFPU)
 
391
      else
 
392
        macosHasFPU := false;
 
393
 
 
394
      if Gestalt(FourCharCodeToLongword(gestaltCFMAttr), response) = noErr then
 
395
        macosHasCFM := BitIsSet(response, gestaltCFMPresent)
 
396
      else
 
397
        macosHasCFM := false;
 
398
 
 
399
      macosHasAppleEvents := Gestalt(FourCharCodeToLongword(gestaltAppleEventsAttr), response) = noErr;
 
400
      macosHasAliasMgr := Gestalt(FourCharCodeToLongword(gestaltAliasMgrAttr), response) = noErr;
 
401
 
 
402
      if Gestalt(FourCharCodeToLongword(gestaltFSAttr), response) = noErr then
 
403
        macosHasFSSpec := BitIsSet(response, gestaltHasFSSpecCalls)
 
404
      else
 
405
        macosHasFSSpec := false;
 
406
      macosHasFindFolder := Gestalt(FourCharCodeToLongword(gestaltFindFolderAttr), response) = noErr;
 
407
 
 
408
      if macosHasScriptMgr then
 
409
        begin
 
410
          err := Gestalt(FourCharCodeToLongword(gestaltScriptCount), response);
 
411
          if (err = noErr) then
 
412
            macosNrOfScriptsInstalled := Integer(response);
 
413
        end;
 
414
 
 
415
      if (Gestalt(FourCharCodeToLongword(gestaltAppearanceAttr), response) = noErr) then
 
416
        begin
 
417
          macosHasAppearance := BitIsSet(response, gestaltAppearanceExists);
 
418
          if Gestalt(FourCharCodeToLongword(gestaltAppearanceVersion), response) = noErr then
 
419
            begin
 
420
              macosHasAppearance101 := (response >= $101);
 
421
              macosHasAppearance11 := (response >= $110);
 
422
            end
 
423
        end
 
424
      else
 
425
        begin
 
426
          macosHasAppearance := false;
 
427
          macosHasAppearance101 := false;
 
428
          macosHasAppearance11 := false;
 
429
        end;
 
430
    end;
 
431
end;
 
432
 
 
433
{*****************************************************************************
 
434
                         System Dependent Exit code
 
435
*****************************************************************************}
 
436
 
 
437
Procedure system_exit;
 
438
var
 
439
  s: ShortString;
 
440
begin
 
441
  if StandAlone <> 0 then
 
442
    if exitcode <> 0 then
 
443
        begin
 
444
          Str(exitcode,s);
 
445
          if IsConsole then
 
446
            Writeln( '### Program exited with exit code ' + s)
 
447
          else if macosHasSysDebugger then
 
448
            DebugStr('A possible error occured, exit code: ' + s + '. Type "g" and return to continue.')
 
449
          else
 
450
            {Be quiet}
 
451
        end;
 
452
 
 
453
  {$ifndef MACOS_USE_STDCLIB}
 
454
  if StandAlone <> 0 then
 
455
    ExitToShell;
 
456
  {$else}
 
457
  c_exit(exitcode); {exitcode is only utilized by an MPW tool}
 
458
  {$endif}
 
459
end;
 
460
 
 
461
procedure SysInitStdIO;
 
462
begin
 
463
  { Setup stdin, stdout and stderr }
 
464
  {$ifdef MACOS_USE_STDCLIB}
 
465
     OpenStdIO(Input,fmInput,StdInputHandle);
 
466
     OpenStdIO(Output,fmOutput,StdOutputHandle);
 
467
     OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
 
468
     OpenStdIO(StdOut,fmOutput,StdOutputHandle);
 
469
     OpenStdIO(StdErr,fmOutput,StdErrorHandle);
 
470
  {$endif }
 
471
end;
 
472
 
 
473
function GetProcessID: SizeUInt;
 
474
begin
 
475
 GetProcessID := 1;
 
476
{$WARNING To be implemented - using GetProcessInformation???}
 
477
end;
 
478
 
 
479
function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
 
480
begin
 
481
  result := stklen;
 
482
end;
 
483
 
 
484
var
 
485
  resHdl: Mac_Handle;
 
486
  isFolder, hadAlias, leafIsAlias: Boolean;
 
487
  dirStr: string[2];
 
488
  err: OSErr;
 
489
  dummySysFolderDirID: Longint;
 
490
 
 
491
begin
 
492
  InvestigateSystem; {Must be first}
 
493
 
 
494
  {Check requred features for system.pp to work.}
 
495
  if not macosHasFSSpec then
 
496
    Halt(3);  //exit code 3 according to MPW
 
497
 
 
498
  if FindSysFolder(macosBootVolumeVRefNum, dummySysFolderDirID) <> noErr then
 
499
    Halt(3);  //exit code 3 according to MPW
 
500
 
 
501
  if GetVolumeName(macosBootVolumeVRefNum, macosBootVolumeName) <> noErr then
 
502
    Halt(3);  //exit code 3 according to MPW
 
503
 
 
504
  { To be set if this is a GUI or console application }
 
505
  if StandAlone = 0 then
 
506
    IsConsole := true {Its an MPW tool}
 
507
  else
 
508
    begin
 
509
      resHdl:= Get1Resource(FourCharCodeToLongword('siow'),0);
 
510
      IsConsole := (resHdl <> nil); {A SIOW app is also a console}
 
511
      ReleaseResource(resHdl);
 
512
    end;
 
513
 
 
514
  { To be set if this is a library and not a program  }
 
515
  IsLibrary := FALSE;
 
516
 
 
517
  StackLength := CheckInitialStkLen(InitialStkLen);
 
518
  StackBottom := SPtr - StackLength;
 
519
  pathTranslation:= false;
 
520
 
 
521
  { Setup working directory }
 
522
  if StandAlone <> 0 then
 
523
    begin
 
524
      if not GetAppFileLocation(workingDirectorySpec) then
 
525
        Halt(3);  //exit code 3 according to MPW
 
526
    end
 
527
  else
 
528
    begin
 
529
      { The fictive file x is used to make
 
530
        FSMakeFSSpec return a FSSpec to a file in the directory.
 
531
        Then by clearing the name, the FSSpec then
 
532
        points to the directory. It doesn't matter whether x exists or not.}
 
533
      dirStr:= ':x';
 
534
      err:= ResolveFolderAliases(0, 0, @dirStr, true,
 
535
           workingDirectorySpec, isFolder, hadAlias, leafIsAlias);
 
536
      workingDirectorySpec.name:='';
 
537
      if (err <> noErr) and (err <> fnfErr) then
 
538
        Halt(3);  //exit code 3 according to MPW
 
539
    end;
 
540
 
 
541
  { Setup heap }
 
542
  if StandAlone <> 0 then
 
543
    MaxApplZone;
 
544
 
 
545
  InitHeap;
 
546
  SysInitExceptions;
 
547
  SysInitStdIO;
 
548
 
 
549
  { Setup environment and arguments }
 
550
  Setup_Environment;
 
551
  setup_arguments;
 
552
  { Reset IO Error }
 
553
  InOutRes:=0;
 
554
  errno:=0;
 
555
  InitSystemThreads;
 
556
  initvariantmanager;
 
557
  initwidestringmanager;
 
558
 
 
559
  if StandAlone = 0 then
 
560
    begin
 
561
      InitGraf(@qd.thePort);
 
562
      SetFScaleDisable(true);
 
563
      InitCursorCtl(nil);
 
564
    end;
 
565
end.