← Back to branch summary

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

« back to all changes in this revision

Viewing changes to fpcsrc/rtl/emx/sysdir.inc

  • 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/emx/sysdir.inc
 
1
{
 
2
    This file is part of the Free Pascal run time library.
 
3
    Copyright (c) 1999-2000 by Florian Klaempfl and Pavel Ozerski
 
4
    member of the Free Pascal development team.
 
5
 
 
6
    FPC Pascal system unit for the Win32 API.
 
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
{*****************************************************************************
 
19
                           Directory Handling
 
20
*****************************************************************************}
 
21
 
 
22
 
 
23
procedure dosdir(func:byte;const s:string);
 
24
 
 
25
var buffer:array[0..255] of char;
 
26
 
 
27
begin
 
28
    move(s[1],buffer,length(s));
 
29
    buffer[length(s)]:=#0;
 
30
    allowslash(Pchar(@buffer));
 
31
    asm
 
32
        leal buffer,%edx
 
33
        movb func,%ah
 
34
        call syscall
 
35
        jnc  .LDOS_DIRS1
 
36
        movw %ax,inoutres
 
37
    .LDOS_DIRS1:
 
38
    end ['eax', 'edx'];
 
39
end;
 
40
 
 
41
 
 
42
procedure MkDir (const S: string);[IOCHECK];
 
43
 
 
44
var buffer:array[0..255] of char;
 
45
    Rc : word;
 
46
 
 
47
begin
 
48
  If (s='') or (InOutRes <> 0) then
 
49
   exit;
 
50
 if os_mode = osOs2 then
 
51
    begin
 
52
      move(s[1],buffer,length(s));
 
53
      buffer[length(s)]:=#0;
 
54
      allowslash(Pchar(@buffer));
 
55
      Rc := DosCreateDir(buffer,nil);
 
56
      if Rc <> 0 then
 
57
       begin
 
58
         InOutRes := Rc;
 
59
         Errno2Inoutres;
 
60
       end;
 
61
    end
 
62
  else
 
63
   begin
 
64
     { Under EMX 0.9d DOS this routine call may sometimes fail   }
 
65
     { The syscall documentation indicates clearly that this     }
 
66
     { routine was NOT tested.                                   }
 
67
        DosDir ($39, S);
 
68
end;
 
69
end;
 
70
 
 
71
 
 
72
procedure rmdir(const s : string);[IOCHECK];
 
73
var buffer:array[0..255] of char;
 
74
    Rc : word;
 
75
begin
 
76
  if (s = '.' ) then
 
77
    InOutRes := 16;
 
78
  If (s='') or (InOutRes <> 0) then
 
79
   exit;
 
80
  if os_mode = osOs2 then
 
81
    begin
 
82
      move(s[1],buffer,length(s));
 
83
      buffer[length(s)]:=#0;
 
84
      allowslash(Pchar(@buffer));
 
85
      Rc := DosDeleteDir(buffer);
 
86
      if Rc <> 0 then
 
87
       begin
 
88
         InOutRes := Rc;
 
89
         Errno2Inoutres;
 
90
       end;
 
91
    end
 
92
  else
 
93
   begin
 
94
     { Under EMX 0.9d DOS this routine call may sometimes fail   }
 
95
     { The syscall documentation indicates clearly that this     }
 
96
     { routine was NOT tested.                                   }
 
97
        DosDir ($3A, S);
 
98
end;
 
99
end;
 
100
 
 
101
{$ASMMODE INTEL}
 
102
 
 
103
procedure ChDir (const S: string);[IOCheck];
 
104
 
 
105
var RC: cardinal;
 
106
    Buffer: array [0..255] of char;
 
107
 
 
108
begin
 
109
  If (s='') or (InOutRes <> 0) then
 
110
   exit;
 
111
(* According to EMX documentation, EMX has only one current directory
 
112
   for all processes, so we'll use native calls under OS/2. *)
 
113
            if os_Mode = osOS2 then
 
114
                begin
 
115
                    if (Length (S) >= 2) and (S [2] = ':') then
 
116
                        begin
 
117
                            RC := DosSetDefaultDisk ((Ord (S [1]) and
 
118
                                                             not ($20)) - $40);
 
119
                            if RC <> 0 then
 
120
                                InOutRes := RC
 
121
                            else
 
122
                                if Length (S) > 2 then
 
123
                                    begin
 
124
                                        Move (S [1], Buffer, Length (S));
 
125
                                        Buffer [Length (S)] := #0;
 
126
                                        AllowSlash (PChar (@Buffer));
 
127
                                        RC := DosSetCurrentDir (@Buffer);
 
128
                                        if RC <> 0 then
 
129
                                         begin
 
130
                                            InOutRes := RC;
 
131
                                            Errno2InOutRes;
 
132
                                         end;
 
133
                                    end;
 
134
                        end
 
135
                    else
 
136
                        begin
 
137
                            Move (S [1], Buffer, Length (S));
 
138
                            Buffer [Length (S)] := #0;
 
139
                            AllowSlash (PChar (@Buffer));
 
140
                            RC := DosSetCurrentDir (@Buffer);
 
141
                            if RC <> 0 then
 
142
                             begin
 
143
                                  InOutRes:= RC;
 
144
                                  Errno2InOutRes;
 
145
                             end;
 
146
                        end;
 
147
                end
 
148
            else
 
149
                if (Length (S) >= 2) and (S [2] = ':') then
 
150
                    begin
 
151
                        asm
 
152
                            mov esi, S
 
153
                            mov al, [esi + 1]
 
154
                            and al, not (20h)
 
155
                            sub al, 41h
 
156
                            mov edx, eax
 
157
                            mov ah, 0Eh
 
158
                            call syscall
 
159
                            mov ah, 19h
 
160
                            call syscall
 
161
                            cmp al, dl
 
162
                            jz @LCHDIR
 
163
                            mov InOutRes, 15
 
164
@LCHDIR:
 
165
                        end ['eax','edx','esi'];
 
166
                        if (Length (S) > 2) and (InOutRes <> 0) then
 
167
                            { Under EMX 0.9d DOS this routine may sometime }
 
168
                            { fail or crash the system.                    }
 
169
                            DosDir ($3B, S);
 
170
                    end
 
171
                else
 
172
                    { Under EMX 0.9d DOS this routine may sometime }
 
173
                    { fail or crash the system.                    }
 
174
                    DosDir ($3B, S);
 
175
end;
 
176
 
 
177
{$ASMMODE ATT}
 
178
 
 
179
procedure GetDir (DriveNr: byte; var Dir: ShortString);
 
180
 
 
181
{Written by Michael Van Canneyt.}
 
182
 
 
183
var sof:Pchar;
 
184
    i:byte;
 
185
 
 
186
begin
 
187
    Dir [4] := #0;
 
188
    { Used in case the specified drive isn't available }
 
189
    sof:=pchar(@dir[4]);
 
190
    { dir[1..3] will contain '[drivenr]:\', but is not }
 
191
    { supplied by DOS, so we let dos string start at   }
 
192
    { dir[4]                                           }
 
193
    { Get dir from drivenr : 0=default, 1=A etc... }
 
194
    asm
 
195
        movb drivenr,%dl
 
196
        movl sof,%esi
 
197
        mov  $0x47,%ah
 
198
        call syscall
 
199
        jnc .LGetDir
 
200
        movw %ax, InOutRes
 
201
.LGetDir:
 
202
    end [ 'eax','edx','esi'];
 
203
    { Now Dir should be filled with directory in ASCIIZ, }
 
204
    { starting from dir[4]                               }
 
205
    dir[0]:=#3;
 
206
    dir[2]:=':';
 
207
    dir[3]:='\';
 
208
    i:=4;
 
209
    {Conversion to Pascal string }
 
210
    while (dir[i]<>#0) do
 
211
        begin
 
212
            { convert path name to DOS }
 
213
            if dir[i]='/' then
 
214
            dir[i]:='\';
 
215
            dir[0]:=char(i);
 
216
            inc(i);
 
217
        end;
 
218
    { upcase the string (FPC function) }
 
219
    if drivenr<>0 then   { Drive was supplied. We know it }
 
220
        dir[1]:=chr(64+drivenr)
 
221
    else
 
222
        begin
 
223
            { We need to get the current drive from DOS function 19H  }
 
224
            { because the drive was the default, which can be unknown }
 
225
            asm
 
226
                movb $0x19,%ah
 
227
                call syscall
 
228
                addb $65,%al
 
229
                movb %al,i
 
230
            end ['eax'];
 
231
            dir[1]:=char(i);
 
232
        end;
 
233
    if not (FileNameCaseSensitive) then dir:=upcase(dir);
 
234
end;
 
235
 
 
236
 
 
237