3 This file is part of the Free Pascal run time library.
4 Copyright (c) 1999-2000 by Carl Eric Codere
6 Marcel Timmermans - Modula 2 Compiler
7 Nils Sjoholm - Amiga porter
8 Matthew Dillon - Dice C (with his kind permission)
11 See the file COPYING.FPC, included in this distribution,
12 for details about the copyright.
14 This program is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
18 **********************************************************************}
21 {--------------------------------------------------------------------}
23 {--------------------------------------------------------------------}
24 { o GetDir with different drive numbers }
25 {--------------------------------------------------------------------}
29 { AmigaOS uses character #10 as eoln only }
30 {$DEFINE SHORT_LINEBREAK}
34 { used for single computations }
42 UnusedHandle
: longint = -1;
43 StdInputHandle
: longint = 0;
44 StdOutputHandle
: longint = 0;
45 StdErrorHandle
: longint = 0;
47 _ExecBase
:longint = $4;
48 _WorkbenchMsg
: longint = 0;
50 _IntuitionBase
: pointer = nil; { intuition library pointer }
51 _DosBase
: pointer = nil; { DOS library pointer }
52 _UtilityBase
: pointer = nil; { utiity library pointer }
54 { Required for crt unit }
55 function do_read(h
,addr
,len
: longint) : longint;
56 function do_write(h
,addr
,len
: longint) : longint;
66 intuitionname
: pchar
= 'intuition.library';
67 dosname
: pchar
= 'dos.library';
68 utilityname
: pchar
= 'utility.library';
70 { AmigaOS does not autoamtically deallocate memory on program termination }
71 { therefore we have to handle this manually. This is a list of allocated }
72 { pointers from the OS, we cannot use a linked list, because the linked }
73 { list itself uses the HEAP! }
74 pointerlist
: array[1..8] of longint =
81 TDateStamp
= packed record
82 ds_Days
: Longint; { Number of days since Jan. 1, 1978 }
83 ds_Minute
: Longint; { Number of minutes past midnight }
84 ds_Tick
: Longint; { Number of ticks past minute }
86 PDateStamp
= ^TDateStamp
;
89 PFileInfoBlock
= ^TfileInfoBlock
;
90 TFileInfoBlock
= packed record
91 fib_DiskKey
: Longint;
92 fib_DirEntryType
: Longint;
93 { Type of Directory. If < 0, then a plain file.
95 fib_FileName
: Array [0..107] of Char;
96 { Null terminated. Max 30 chars used for now }
97 fib_Protection
: Longint;
98 { bit mask of protection, rwxd are 3-0. }
99 fib_EntryType
: Longint;
100 fib_Size
: Longint; { Number of bytes in file }
101 fib_NumBlocks
: Longint; { Number of blocks in file }
102 fib_Date
: TDateStamp
; { Date file last changed }
103 fib_Comment
: Array [0..79] of Char;
104 { Null terminated comment associated with file }
105 fib_Reserved
: Array [0..35] of Char;
109 TProcess
= packed record
111 pr_MsgPort
: TMsgPort
; { This is BPTR address from DOS functions }
112 {126} pr_Pad
: Word; { Remaining variables on 4 byte boundaries }
113 {128} pr_SegList
: Pointer; { Array of seg lists used by this process }
114 {132} pr_StackSize
: Longint; { Size of process stack in bytes }
115 {136} pr_GlobVec
: Pointer; { Global vector for this process (BCPL) }
116 {140} pr_TaskNum
: Longint; { CLI task number of zero if not a CLI }
117 {144} pr_StackBase
: BPTR
; { Ptr to high memory end of process stack }
118 {148} pr_Result2
: Longint; { Value of secondary result from last call }
119 {152} pr_CurrentDir
: BPTR
; { Lock associated with current directory }
120 {156} pr_CIS
: BPTR
; { Current CLI Input Stream }
121 {160} pr_COS
: BPTR
; { Current CLI Output Stream }
122 {164} pr_ConsoleTask
: Pointer; { Console handler process for current window}
123 {168} pr_FileSystemTask
: Pointer; { File handler process for current drive }
124 {172} pr_CLI
: BPTR
; { pointer to ConsoleLineInterpreter }
125 pr_ReturnAddr
: Pointer; { pointer to previous stack frame }
126 pr_PktWait
: Pointer; { Function to be called when awaiting msg }
127 pr_WindowPtr
: Pointer; { Window for error printing }
128 { following definitions are new with 2.0 }
129 pr_HomeDir
: BPTR
; { Home directory of executing program }
130 pr_Flags
: Longint; { flags telling dos about process }
131 pr_ExitCode
: Pointer; { code to call on exit of program OR NULL }
132 pr_ExitData
: Longint; { Passed as an argument to pr_ExitCode. }
133 pr_Arguments
: PChar
; { Arguments passed to the process at start }
134 pr_LocalVars
: TMinList
; { Local environment variables }
135 pr_ShellPrivate
: Longint; { for the use of the current shell }
136 pr_CES
: BPTR
; { Error stream - IF NULL, use pr_COS }
138 PProcess
= ^TProcess
;
140 { AmigaOS does not automatically close opened files on exit back to }
141 { the operating system, therefore as a precuation we close all files }
142 { manually on exit. }
143 PFileList
= ^TFileList
;
144 TFileList
= record { no packed, must be correctly aligned }
145 Handle
: longint; { Handle to file }
146 next
: pfilelist
; { Next file in list }
147 closed
: boolean; { TRUE=file already closed }
154 CTRL_C
= 20; { Error code on CTRL-C press }
155 SIGBREAKF_CTRL_C
= $1000; { CTRL-C signal flags }
160 _LVOOpenLibrary
= -552;
161 _LVOCloseLibrary
= -414;
166 _LVODeleteFile
= -72;
170 _LVOCreateDir
= -120;
171 _LVOSetCurrentDirName
= -558;
172 _LVOGetCurrentDirName
= -564;
177 _LVOCurrentDir
= -126;
179 _LVONameFromLock
= -402;
180 _LVONameFromFH
= -408;
181 _LVOGetProgramName
= -576;
182 _LVOGetProgramDir
= -600;
185 _LVOParentDir
= -210;
186 _LVOSetFileSize
= -456;
187 _LVOSetSignal
= -306;
192 { Errors from IoErr(), etc. }
193 ERROR_NO_FREE_STORE
= 103;
194 ERROR_TASK_TABLE_FULL
= 105;
195 ERROR_BAD_TEMPLATE
= 114;
196 ERROR_BAD_NUMBER
= 115;
197 ERROR_REQUIRED_ARG_MISSING
= 116;
198 ERROR_KEY_NEEDS_ARG
= 117;
199 ERROR_TOO_MANY_ARGS
= 118;
200 ERROR_UNMATCHED_QUOTES
= 119;
201 ERROR_LINE_TOO_LONG
= 120;
202 ERROR_FILE_NOT_OBJECT
= 121;
203 ERROR_INVALID_RESIDENT_LIBRARY
= 122;
204 ERROR_NO_DEFAULT_DIR
= 201;
205 ERROR_OBJECT_IN_USE
= 202;
206 ERROR_OBJECT_EXISTS
= 203;
207 ERROR_DIR_NOT_FOUND
= 204;
208 ERROR_OBJECT_NOT_FOUND
= 205;
209 ERROR_BAD_STREAM_NAME
= 206;
210 ERROR_OBJECT_TOO_LARGE
= 207;
211 ERROR_ACTION_NOT_KNOWN
= 209;
212 ERROR_INVALID_COMPONENT_NAME
= 210;
213 ERROR_INVALID_LOCK
= 211;
214 ERROR_OBJECT_WRONG_TYPE
= 212;
215 ERROR_DISK_NOT_VALIDATED
= 213;
216 ERROR_DISK_WRITE_PROTECTED
= 214;
217 ERROR_RENAME_ACROSS_DEVICES
= 215;
218 ERROR_DIRECTORY_NOT_EMPTY
= 216;
219 ERROR_TOO_MANY_LEVELS
= 217;
220 ERROR_DEVICE_NOT_MOUNTED
= 218;
221 ERROR_SEEK_ERROR
= 219;
222 ERROR_COMMENT_TOO_BIG
= 220;
223 ERROR_DISK_FULL
= 221;
224 ERROR_DELETE_PROTECTED
= 222;
225 ERROR_WRITE_PROTECTED
= 223;
226 ERROR_READ_PROTECTED
= 224;
227 ERROR_NOT_A_DOS_DISK
= 225;
229 ERROR_NO_MORE_ENTRIES
= 232;
231 ERROR_IS_SOFT_LINK
= 233;
232 ERROR_OBJECT_LINKED
= 234;
233 ERROR_BAD_HUNK
= 235;
234 ERROR_NOT_IMPLEMENTED
= 236;
235 ERROR_RECORD_NOT_LOCKED
= 240;
236 ERROR_LOCK_COLLISION
= 241;
237 ERROR_LOCK_TIMEOUT
= 242;
238 ERROR_UNLOCK_ERROR
= 243;
243 Initial
: boolean; { Have successfully opened Std I/O }
244 errno
: word; { AmigaOS IO Error number }
245 FileList
: pFileList
; { Linked list of opened files }
246 {old_exit: Pointer; not needed anymore }
248 OrigDir
: Longint; { Current lock on original startup directory }
256 { ************************ AMIGAOS STUB ROUTINES ************************* }
258 procedure DateStamp(var ds
: tDateStamp
);
263 { LAST THING TO SETUP SHOULD BE A6, otherwise you can }
264 { not accept local variable, nor any parameters! :) }
273 { UNLOCK the BPTR pointed to in L }
274 Procedure Unlock(alock
: longint);
278 move.l a6
,d6
{ save base pointer }
281 move.l d6
,a6
{ restore base pointer }
285 { Change to the directory pointed to in the lock }
286 Function CurrentDir(alock
: longint) : longint;
290 move.l a6
,d6
{ save base pointer }
292 jsr _LVOCurrentDir
(a6
)
293 move.l d6
,a6
{ restore base pointer }
299 Function DupLock(alock
: longint): Longint;
303 move.l a6
,d6
{ save base pointer }
306 move.l d6
,a6
{ restore base pointer }
311 { Returns a lock on the directory was loaded from }
312 Function GetProgramLock
: longint;
315 move.l a6
,d6
{ save base pointer }
317 jsr _LVOGetProgramDir
(a6
)
318 move.l d6
,a6
{ restore base pointer }
325 Function Examine(alock
:longint; var fib
: TFileInfoBlock
) : Boolean;
329 move.l fib
,d2
{ pointer to FIB }
331 move.l a6
,d6
{ save base pointer }
334 move.l d6
,a6
{ restore base pointer }
346 { Returns the parent directory of a lock }
347 Function ParentDir(alock
: longint): longint;
351 move.l a6
,d6
{ save base pointer }
353 jsr _LVOParentDir
(a6
)
354 move.l d6
,a6
{ restore base pointer }
360 Function FindTask(p
: PChar
): PProcess
;
363 move.l a6
,d6
{ Save base pointer }
368 move.l d6
,a6
{ Restore base pointer }
375 Procedure stack_check
; assembler;
376 { Check for local variable allocation }
377 { On Entry -> d0 : size of local stack we are trying to allocate }
380 move.l
sp,d1
{ get value of stack pointer }
382 { We must add some security, because Writing the RunError strings }
383 { requires a LOT of stack space (at least 1030 bytes!) }
385 sub.l d0
,d1
{ sp - stack_size }
388 move.l
276(A0
),A0
{ ExecBase.thisTask }
389 { if allocated stack_pointer - splower <= 0 then stack_ovf }
390 cmp.l
58(A0
),D1
{ Task.SpLower }
393 jsr HALT_ERROR
{ stack overflow }
398 { This routine from EXEC determines if the Ctrl-C key has }
399 { been used since the last call to I/O routines. }
400 { Use to halt the program. }
401 { Returns the state of the old signals. }
402 Function SetSignal(newSignal
: longint; SignalMask
: longint): longint;
407 move.l a6
,d6
{ save Base pointer into scratch register }
409 jsr _LVOSetSignal
(a6
)
416 Function AllocVec(bytesize
: longint; attributes
: longint):longint;
421 move.l a6
,d6
{ save Base pointer into scratch register }
430 Procedure FreeVec(p
: longint);
434 move.l a6
,d6
{ save Base pointer into scratch register }
442 { Converts an AMIGAOS error code to a TP compatible error code }
443 Procedure Error2InOut
;
447 ERROR_ACTION_NOT_KNOWN
,
448 ERROR_NOT_IMPLEMENTED
: InOutRes
:= 1;
450 ERROR_OBJECT_NOT_FOUND
: InOutRes
:= 2;
451 ERROR_DIR_NOT_FOUND
: InOutRes
:= 3;
453 ERROR_DISK_WRITE_PROTECTED
: InOutRes
:= 150;
455 ERROR_OBJECT_WRONG_TYPE
: InOutRes
:= 151;
458 ERROR_DELETE_PROTECTED
,
459 ERROR_WRITE_PROTECTED
,
460 ERROR_READ_PROTECTED
,
462 ERROR_DIRECTORY_NOT_EMPTY
: InOutRes
:= 5;
464 ERROR_NO_MORE_ENTRIES
: InOutRes
:= 18;
466 ERROR_RENAME_ACROSS_DEVICES
: InOutRes
:= 17;
468 ERROR_DISK_FULL
: InOutRes
:= 101;
470 ERROR_INVALID_RESIDENT_LIBRARY
: InoutRes
:= 153;
471 ERROR_BAD_HUNK
: InOutRes
:= 153;
473 ERROR_NOT_A_DOS_DISK
: InOutRes
:= 157;
476 ERROR_DISK_NOT_VALIDATED
,
477 ERROR_DEVICE_NOT_MOUNTED
: InOutRes
:= 152;
479 ERROR_SEEK_ERROR
: InOutRes
:= 156;
481 ERROR_LOCK_COLLISION
,
485 ERROR_INVALID_COMPONENT_NAME
,
486 ERROR_BAD_STREAM_NAME
,
487 ERROR_FILE_NOT_OBJECT
: InOutRes
:= 6;
495 procedure CloseLibrary(lib
: pointer);
496 { Close the library pointed to in lib }
502 JSR _LVOCloseLibrary
(A6
)
508 Function KickVersion
: word; assembler;
510 move.l _ExecBase
, a0
{ Get Exec Base }
511 move.w
20(a0
), d0
{ Return version - version at this offset }
515 { ************************ AMIGAOS SUPP ROUTINES ************************* }
517 (* Procedure CloseList(p: pFileList);*)
518 (***********************************************************************)
519 (* PROCEDURE CloseList *)
520 (* Description: This routine each time the program is about to *)
521 (* terminate, it closes all opened file handles, as this is not *)
522 (* handled by the operating system. *)
523 (* p -> Start of linked list of opened files *)
524 (***********************************************************************)
531 while Assigned(hp) do
533 if NOT hp^.closed then
536 if (h <> StdInputHandle) and (h <> StdOutputHandle) and (h <> StdErrorHandle) then
538 { directly close file here, it is faster then doing }
542 move.l a6,d6 { save a6 }
545 move.l d6,a6 { restore a6 }
556 (* Procedure AddToList(var p: pFileList; h: longint);*)
557 (***********************************************************************)
558 (* PROCEDURE AddToList *)
559 (* Description: Adds a node to the linked list of files. *)
561 (* p -> Start of File list linked list, if not allocated allocates *)
563 (* h -> handle of file to add *)
564 (***********************************************************************)
578 { Find last list in entry }
579 while assigned(hp) do
581 if hp^.next = nil then break;
584 { Found last list in entry then add it to the list }
593 Procedure SetClosedList(var p: pFileList; h: longint);
594 { Set the file flag to closed if the file is being closed }
599 while assigned(hp) do
601 if hp^.handle = h then
611 {*****************************************************************************
612 System Dependent Exit code
613 *****************************************************************************}
614 Procedure system_exit;
618 { We must remove the CTRL-C FALG here because halt }
619 { may call I/O routines, which in turn might call }
620 { halt, so a recursive stack crash }
621 IF (SetSignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 THEN
622 SetSignal(0,SIGBREAKF_CTRL_C);
623 { Close remaining opened files }
624 { CloseList(FileList); }
625 if (OrigDir <> 0) then
627 Unlock(CurrentDir(OrigDir));
630 { Is this a normal exit - YES, close libs }
633 { close the libraries }
634 If _UtilityBase <> nil then
635 CloseLibrary(_UtilityBase);
636 If _DosBase <> nil then
637 CloseLibrary(_DosBase);
638 If _IntuitionBase <> nil then
639 CloseLibrary(_IntuitionBase);
642 _IntuitionBase := nil;
644 { Dispose of extraneous allocated pointers }
647 if pointerlist[i] <> 0 then FreeVec(pointerlist[i]);
649 { exitproc:=old_exit;obsolete }
653 procedure halt(errnum : byte);
655 { Indicate to the SYSTEM EXIT procedure that we are calling it }
656 { from halt, and that its library will be closed HERE and not }
657 { in the exit procedure. }
659 { We must remove the CTRL-C FALG here because halt }
660 { may call I/O routines, which in turn might call }
661 { halt, so a recursive stack crash }
662 IF (SetSignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 THEN
663 SetSignal(0,SIGBREAKF_CTRL_C);
664 { WE can only FLUSH the stdio }
665 { if the handles have correctly }
667 { No exit procedures exist }
668 { if in initial state }
674 { close the libraries }
675 If _UtilityBase <> nil then
676 CloseLibrary(_UtilityBase);
677 If _DosBase <> nil then
678 CloseLibrary(_DosBase);
679 If _IntuitionBase <> nil then
680 CloseLibrary(_IntuitionBase);
683 _IntuitionBase := nil;
694 { ************************ PARAMCOUNT/PARAMSTR *************************** }
696 function paramcount : longint;
702 function args : pointer; assembler;
707 Function GetParamCount(const p: pchar): longint;
714 while p[count] <> #0 do
716 if (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) then
719 while (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) do
722 if p[count] = #0 then break;
725 GetParamCount:=longint(i);
729 Function GetParam(index: word; const p : pchar): string;
730 { On Entry: index = string index to correct parameter }
731 { On exit: = correct character index into pchar array }
732 { Returns correct index to command line argument }
741 { first index is one }
744 While p[count] <> #0 do
746 if (p[count] <> ' ') and (p[count] <> #9) then
748 if localindex = index then
750 while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) and (l < 256) do
760 { Point to next argument in list }
761 while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) do
765 localindex:=localindex+1;
767 if p[count] = #0 then break;
774 Function GetProgramDir : String;
780 FillChar(@s1,255,#0);
781 { GetLock of program directory }
783 move.l a6,d6 { save a6 }
785 jsr _LVOGetProgramDir(a6)
786 move.l d6,a6 { restore a6 }
787 move.l d0,alock { save the lock }
791 { Get the name from the lock! }
793 movem.l d2/d3,-(sp) { save used registers }
795 lea s1,a0 { Get pointer to string! }
797 add.l #1,d2 { let us point past the length byte! }
799 move.l a6,d6 { save a6 }
801 jsr _LVONameFromLock(a6)
802 move.l d6,a6 { restore a6 }
805 { no check out the length of the string }
807 while s1[counter] <> #0 do
809 s1[0] := char(counter-1);
817 Function GetProgramName : string;
818 { Returns ONLY the program name }
819 { There seems to be a bug in v39 since if the program is not }
820 { called from its home directory the program name will also }
821 { contain the path! }
826 FillChar(@s1,255,#0);
828 move.l d2,-(sp) { Save used register }
829 lea s1,a0 { Get pointer to string! }
831 add.l #1,d1 { point to correct offset }
833 move.l a6,d6 { save a6 }
835 jsr _LVOGetProgramName(a6)
836 move.l d6,a6 { restore a6 }
837 move.l (sp)+,d2 { restore saved register }
839 { no check out and assign the length of the string }
841 while s1[counter] <> #0 do
843 s1[0] := char(counter-1);
844 { now remove any component path which should not be there }
845 for counter:=length(s1) downto 1 do
846 if (s1[counter] = '/') or (s1[counter] = ':') then break;
847 { readjust counterv to point to character }
850 GetProgramName:=copy(s1,counter,length(s1));
854 function paramstr(l : longint) : string;
859 { -> Call AmigaOS GetProgramName }
863 { If this is a root, then simply don't add '/' }
864 if s1[length(s1)] = ':' then
865 paramstr:=s1+GetProgramName
867 { add backslash directory }
868 paramstr:=s1+'/'+GetProgramName
871 if (l>0) and (l<=paramcount) then
874 paramstr:=GetParam(word(l),p);
879 { ************************************************************************ }
888 randseed:=time.ds_tick;
891 function getheapstart:pointer;assembler;
898 function getheapsize:longint;assembler;
903 { This routine is used to grow the heap. }
904 { But here we do a trick, we say that the }
905 { heap cannot be regrown! }
906 function sbrk( size: longint): longint;
908 { on exit -1 = if fails. }
913 { Is the pointer list full }
914 if pointerlist[8] <> 0 then
916 { yes, then don't allocate and simply exit }
920 { Allocate best available memory }
927 { add it to the list of allocated pointers }
928 { first find the last pointer in the list }
929 while (i < 8) and (pointerlist[i] <> 0) do
941 {****************************************************************************
942 Low Level File Routines
943 ****************************************************************************}
945 procedure do_close(h : longint);
946 { We cannot check for CTRL-C because this routine will be called }
947 { on HALT to close all remaining opened files. Therefore no }
948 { CTRL-C checking otherwise a recursive call might result! }
951 buffer: array[0..255] of char;
954 { check if the file handle is in the list }
955 { if so the put its field to closed }
956 { SetClosedList(FileList,h);}
967 jsr _LVONameFromFH(a6)
976 move.l a6,d6 { save a6 }
979 move.l d6,a6 { restore a6 }
984 function do_isdevice(handle:longint):boolean;
986 if (handle=stdoutputhandle) or (handle=stdinputhandle) or
987 (handle=stderrorhandle) then
995 procedure do_erase(p : pchar);
997 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
999 SetSignal(0,SIGBREAKF_CTRL_C);
1003 move.l a6,d6 { save a6 }
1007 jsr _LVODeleteFile(a6)
1008 tst.l d0 { zero = failure }
1015 move.l d6,a6 { restore a6 }
1022 procedure do_rename(p1,p2 : pchar);
1024 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1026 SetSignal(0,SIGBREAKF_CTRL_C);
1030 move.l a6,d6 { save a6 }
1031 move.l d2,-(sp) { save d2 }
1037 move.l (sp)+,d2 { restore d2 }
1039 bne @dosreend { if zero = error }
1043 move.l d6,a6 { restore a6 }
1050 function do_write(h,addr,len : longint) : longint;
1052 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1054 SetSignal(0,SIGBREAKF_CTRL_C);
1066 move.l h,d1 { we must of course set up the }
1067 move.l addr,d2 { parameters BEFORE getting }
1068 move.l len,d3 { _DOSBase }
1074 bne @doswrend { if -1 = error }
1079 { we must restore the base pointer before setting the result }
1092 function do_read(h,addr,len : longint) : longint;
1094 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1096 SetSignal(0,SIGBREAKF_CTRL_C);
1108 move.l h,d1 { we must set up aparamters BEFORE }
1109 move.l addr,d2 { setting up a6 for the OS call }
1116 bne @doswrend { if -1 = error }
1121 { to store a result for the function }
1122 { we must of course first get back the}
1136 function do_filepos(handle : longint) : longint;
1138 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1140 { Clear CTRL-C signal }
1141 SetSignal(0,SIGBREAKF_CTRL_C);
1149 move.l d3,-(sp) { save registers }
1151 clr.l d2 { offset 0 }
1152 move.l #0,d3 { OFFSET_CURRENT }
1156 move.l (sp)+,d3 { restore registers }
1158 cmp.l #-1,d0 { is there a file access error? }
1164 move.l d6,a6 { restore a6 }
1168 move.l d6,a6 { restore a6 }
1176 procedure do_seek(handle,pos : longint);
1178 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1180 { Clear CTRL-C signal }
1181 SetSignal(0,SIGBREAKF_CTRL_C);
1189 move.l d3,-(sp) { save registers }
1193 move.l #$ffffffff,d3 { OFFSET_BEGINNING }
1197 move.l (sp)+,d3 { restore registers }
1199 cmp.l #-1,d0 { is there a file access error? }
1206 move.l d6,a6 { restore a6 }
1213 function do_seekend(handle:longint):longint;
1215 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1217 { Clear CTRL-C signal }
1218 SetSignal(0,SIGBREAKF_CTRL_C);
1222 { seek from end of file }
1227 move.l d3,-(sp) { save registers }
1230 move.l #1,d3 { OFFSET_END }
1234 move.l (sp)+,d3 { restore registers }
1236 cmp.l #-1,d0 { is there a file access error? }
1242 move.l d6,a6 { restore a6 }
1246 move.l d6,a6 { restore a6 }
1254 function do_filesize(handle : longint) : longint;
1256 aktfilepos : longint;
1258 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1260 { Clear CTRL-C signal }
1261 SetSignal(0,SIGBREAKF_CTRL_C);
1264 aktfilepos:=do_filepos(handle);
1265 { We have to do this two times, because seek returns the }
1267 do_filesize:=do_seekend(handle);
1268 do_filesize:=do_seekend(handle);
1269 do_seek(handle,aktfilepos);
1273 procedure do_truncate (handle,pos:longint);
1275 { Point to the end of the file }
1276 { with the new size }
1278 @noerr_one: { Seek a second time }
1279 move.l a6,d6 { Save base pointer }
1283 move.l d3,-(sp) { save registers }
1286 move.l #-1,d3 { Setup correct move type }
1287 move.l _DOSBase,a6 { from beginning of file }
1288 jsr _LVOSetFileSize(a6)
1290 move.l (sp)+,d3 { restore registers }
1292 cmp.l #-1,d0 { is there a file access error? }
1295 move.w d0,errno { Global variable, so no need }
1296 @noerr: { to restore base pointer now }
1297 move.l d6,a6 { Restore base pointer }
1304 procedure do_open(var f;p:pchar;flags:longint);
1306 filerec and textrec have both handle and mode as the first items so
1307 they could use the same routine for opening/creating.
1308 when (flags and $100) the file will be append
1309 when (flags and $1000) the file will be truncate/rewritten
1310 when (flags and $10000) there is no check for close (needed for textfiles)
1316 buffer : array[0..255] of char;
1321 for index:=1 to length(path) do
1322 if path[index]='\' then path[index]:='/';
1323 { remove any dot characters and replace by their current }
1324 { directory equivalent. }
1325 if pos('../',path) = 1 then
1326 { look for parent directory }
1331 while (s[j] <> '/') AND (s[j] <> ':') AND (j > 0 ) do
1338 if pos('./',path) = 1 then
1339 { look for current directory }
1343 if (s[length(s)] <> '/') and (s[length(s)] <> ':') then
1347 move(path[1],buffer,length(path));
1348 buffer[length(path)]:=#0;
1349 { close first if opened }
1350 if ((flags and $10000)=0) then
1352 case filerec(f).mode of
1353 fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
1357 inoutres:=102; {not assigned}
1362 { reset file handle }
1363 filerec(f).handle:=UnusedHandle;
1364 { convert filemode to filerec modes }
1365 { READ/WRITE on existing file }
1368 case (flags and 3) of
1370 filerec(f).mode:=fminput;
1372 1 : filerec(f).mode:=fmoutput;
1373 2 : filerec(f).mode:=fminout;
1375 { READ/WRITE mode, create file in all cases }
1377 if (flags and $1000)<>0 then
1379 filerec(f).mode:=fmoutput;
1383 { READ/WRITE mode on existing file }
1385 if (flags and $100)<>0 then
1387 filerec(f).mode:=fmoutput;
1390 { empty name is special }
1393 case filerec(f).mode of
1394 fminput : filerec(f).handle:=StdInputHandle;
1397 filerec(f).handle:=StdOutputHandle;
1398 filerec(f).mode:=fmoutput; {fool fmappend}
1404 move.l a6,d6 { save a6 }
1408 move.l oflags,d2 { MODE_READWRITE }
1412 bne @noopenerror { on zero an error occured }
1418 move.l d6,a6 { restore a6 }
1419 move.l d0,i { we need the base pointer to access this variable }
1422 move.l d6,a6 { restore a6 }
1426 (* if Errno = 0 then*)
1427 { No error, add file handle to linked list }
1428 { this must be checked before the call to }
1429 { Error2InIOut since it resets Errno to 0 }
1430 (* AddToList(FileList,i);*)
1434 filerec(f).handle:=i;
1435 if (flags and $100)<>0 then
1436 do_seekend(filerec(f).handle);
1440 {*****************************************************************************
1441 UnTyped File Handling
1442 *****************************************************************************}
1446 {*****************************************************************************
1448 *****************************************************************************}
1452 {*****************************************************************************
1454 *****************************************************************************}
1458 {*****************************************************************************
1460 *****************************************************************************}
1462 procedure mkdir(const s : string);[IOCheck];
1464 buffer : array[0..255] of char;
1468 { We must check the Ctrl-C before IOChecking of course! }
1469 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1471 { Clear CTRL-C signal }
1472 SetSignal(0,SIGBREAKF_CTRL_C);
1475 If InOutRes <> 0 then exit;
1477 for j:=1 to length(temp) do
1478 if temp[j] = '\' then temp[j] := '/';
1479 move(temp[1],buffer,length(temp));
1480 buffer[length(temp)]:=#0;
1483 { we must load the parameters BEFORE setting up the }
1488 jsr _LVOCreateDir(a6)
1495 { Now we must unlock the directory }
1496 { d0 = lock returned by create dir }
1500 { restore base pointer }
1508 procedure rmdir(const s : string);[IOCheck];
1510 buffer : array[0..255] of char;
1514 { We must check the Ctrl-C before IOChecking of course! }
1515 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1517 { Clear CTRL-C signal }
1518 SetSignal(0,SIGBREAKF_CTRL_C);
1521 If InOutRes <> 0 then exit;
1523 for j:=1 to length(temp) do
1524 if temp[j] = '\' then temp[j] := '/';
1525 move(temp[1],buffer,length(temp));
1526 buffer[length(temp)]:=#0;
1532 procedure chdir(const s : string);[IOCheck];
1534 buffer : array[0..255] of char;
1536 FIB :pFileInfoBlock;
1540 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1542 { Clear CTRL-C signal }
1543 SetSignal(0,SIGBREAKF_CTRL_C);
1546 If InOutRes <> 0 then exit;
1548 for j:=1 to length(temp) do
1549 if temp[j] = '\' then temp[j] := '/';
1550 { Return parent directory }
1555 { Look through the previous paths }
1556 while (temp[j] <> '/') AND (temp[j] <> ':') AND (j > 0 ) do
1559 temp:=copy(temp,1,j);
1565 move(temp[1],buffer,length(temp));
1566 buffer[length(temp)]:=#0;
1567 { Changing the directory is a pretty complicated affair }
1568 { 1) Obtain a lock on the directory }
1569 { 2) CurrentDir the lock }
1572 move.l a0,d1 { pointer to buffer in d1 }
1573 move.l d2,-(sp) { save d2 register }
1574 move.l #-2,d2 { ACCESS_READ lock }
1575 move.l a6,d6 { Save base pointer }
1577 jsr _LVOLock(a6){ Lock the directory }
1578 move.l (sp)+,d2 { Restore d2 register }
1579 tst.l d0 { zero = error! }
1583 move.l d6,a6 { reset base pointer }
1586 move.l d6,a6 { reset base pointer }
1587 move.l d0,alock { save the lock }
1595 if (Examine(alock, fib^) = TRUE) AND (fib^.fib_DirEntryType > 0) then
1597 alock := CurrentDir(alock);
1606 if assigned(fib) then dispose(fib);
1612 Procedure GetCwd(var path: string);
1615 fib: PfileInfoBlock;
1624 { By using a pointer instead of a local variable}
1625 { we are assured that the pointer is aligned on }
1626 { a dword boundary. }
1628 Process := FindTask(nil);
1629 if (process^.pr_Task.tc_Node.ln_Type = NT_TASK) then
1634 lock := DupLock(process^.pr_CurrentDir);
1641 While (lock <> 0) and (Examine(lock,FIB^) = TRUE) do
1643 elen := strlen(fib^.fib_FileName);
1644 if (len + elen + 2 > 255) then
1646 newlock := ParentDir(lock);
1649 if (newlock <> 0) then
1653 path:=strpas(fib^.fib_FileName)+path;
1658 path:=strpas(fib^.fib_Filename);
1659 if (newlock = 0) then
1673 if assigned(fib) then dispose(fib);
1677 procedure getdir(drivenr : byte;var dir : string);
1679 if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then
1681 { Clear CTRL-C signal }
1682 SetSignal(0,SIGBREAKF_CTRL_C);
1691 {*****************************************************************************
1692 SystemUnit Initialization
1693 *****************************************************************************}
1695 Procedure Startup; Assembler;
1697 move.l a6,d6 { save a6 }
1699 move.l (4),a6 { get ExecBase pointer }
1702 jsr _LVOFindTask(a6)
1704 { Check the stack value }
1706 { are we running from a CLI? }
1708 tst.l 172(a0) { 172 = pr_CLI }
1711 { we do not support Workbench yet .. }
1712 move.l d6,a6 { restore a6 }
1717 { Open the following libraries: }
1718 { Intuition.library }
1722 move.l intuitionname,a1 { directly since it is a pchar }
1723 jsr _LVOOpenLibrary(a6)
1724 move.l d0,_IntuitionBase
1728 move.l utilityname,a1 { directly since it is a pchar }
1729 jsr _LVOOpenLibrary(a6)
1730 move.l d0,_UtilityBase
1734 move.l dosname,a1 { directly since it is a pchar }
1735 jsr _LVOOpenLibrary(a6)
1739 { Find standard input and output }
1743 jsr _LVOInput(a6) { get standard in }
1744 move.l d0, StdInputHandle { save standard Input handle }
1745 { move.l d0,d1 }{ set up for next call }
1746 { jsr _LVOIsInteractive(a6)}{ is it interactive? }
1747 { move.l #_Input,a0 }{ get file record again }
1748 { move.b d0,INTERACTIVE(a0) }{ set flag }
1749 { beq StdInNotInteractive }{ skip this if not interactive }
1750 { move.l BUFFER(a0),a1 }{ get buffer address }
1751 { add.l #1,a1 }{ make end one byte further on }
1752 { move.l a1,MAX(a0) }{ set buffer size }
1753 { move.l a1,CURRENT(a0) }{ will need a read }
1755 @StdInNotInteractive
1756 { jsr _p%FillBuffer } { fill the buffer }
1758 jsr _LVOOutput(a6) { get ouput file handle }
1759 move.l d0,StdOutputHandle { get file record }
1761 { move.l d0,d1 } { set up for call }
1762 { jsr _LVOIsInteractive(a6) } { is it interactive? }
1763 { move.l #_Output,a0 } { get file record }
1764 { move.b d0,INTERACTIVE(a0)} { set flag }
1766 move.l d6,a6 { restore a6 }
1770 move.l d6,a6 { restore a6 }
1778 { Initial state is on -- in case of RunErrors before the i/o handles are }
1781 { Initialize ExitProc }
1784 { to test stack depth }
1785 loweststack:=maxlongint;
1788 { Setup stdin, stdout and stderr }
1789 OpenStdIO(Input,fmInput,StdInputHandle);
1790 OpenStdIO(Output,fmOutput,StdOutputHandle);
1791 OpenStdIO(StdOut,fmOutput,StdOutputHandle);
1792 { The Amiga does not seem to have a StdError }
1793 { handle, therefore make the StdError handle }
1794 { equal to the StdOutputHandle. }
1795 StdErrorHandle := StdOutputHandle;
1796 OpenStdIO(StdErr,fmOutput,StdErrorHandle);
1797 { Now Handles and function handlers are setup }
1803 { Only AmigaOS v2.04 or greater is supported }
1804 If KickVersion < 36 then
1806 WriteLn('v36 or greater of Kickstart required.');
1809 argc:=GetParamCount(args);
1817 Revision 1.1 2002/02/19 08:24:33 sasu
1820 Revision 1.1 2000/07/13 06:30:29 michael
1823 Revision 1.15 2000/01/07 16:41:29 daniel
1826 Revision 1.14 2000/01/07 16:32:22 daniel
1827 * copyright 2000 added
1829 Revision 1.13 1999/09/10 15:40:32 peter
1830 * fixed do_open flags to be > $100, becuase filemode can be upto 255
1832 Revision 1.12 1999/01/18 10:05:47 pierre
1833 + system_exit procedure added
1835 Revision 1.11 1998/12/28 15:50:42 peter
1836 + stdout, which is needed when you write something in the system unit
1837 to the screen. Like the runtime error
1839 Revision 1.10 1998/09/14 10:48:00 peter
1841 * Heap manager is now system independent
1843 Revision 1.9 1998/08/17 12:34:22 carl
1844 * chdir accepts .. characters
1845 + added ctrl-c checking
1847 * exit code was never called if no error was found on exit!
1848 * register was not saved in do_open
1850 Revision 1.8 1998/07/13 12:32:18 carl
1851 * do_truncate works, some cleanup
1853 Revision 1.6 1998/07/02 12:37:52 carl
1854 * IOCheck for chdir,rmdir and mkdir as in TP
1856 Revision 1.5 1998/07/01 14:30:56 carl
1857 * forgot that includes are case sensitive
1859 Revision 1.4 1998/07/01 14:13:50 carl
1861 * correct conversion of Amiga error codes to TP error codes
1862 * InoutRes word bugfix
1863 * parameter counting fixed
1864 * new stack checking implemented
1865 + IOCheck for chdir,rmdir,getdir and rmdir
1866 * do_filepos was wrong
1867 + chdir correctly implemented
1868 * getdir correctly implemented
1870 Revision 1.1.1.1 1998/03/25 11:18:47 root
1873 Revision 1.14 1998/03/21 04:20:09 carl
1874 * correct ExecBase pointer (from Nils Sjoholm)
1875 * correct OpenLibrary vector (from Nils Sjoholm)
1877 Revision 1.13 1998/03/14 21:34:32 carl
1878 * forgot to save a6 in Startup routine
1880 Revision 1.12 1998/02/24 21:19:42 carl
1881 *** empty log message ***
1883 Revision 1.11 1998/02/23 02:22:49 carl
1884 * bugfix if linking problems
1886 Revision 1.9 1998/02/06 16:34:32 carl
1887 + do_open is now standard with other platforms
1889 Revision 1.8 1998/02/02 15:01:45 carl
1890 * fixed bug with opening library versions (from Nils Sjoholm)
1892 Revision 1.7 1998/01/31 19:35:19 carl
1893 + added opening of utility.library
1895 Revision 1.6 1998/01/29 23:20:54 peter
1896 - Removed Backslash convert
1898 Revision 1.5 1998/01/27 10:55:04 peter
1899 * Amiga uses / not \, so change AllowSlash -> AllowBackSlash
1901 Revision 1.4 1998/01/25 21:53:20 peter
1902 + Universal Handles support for StdIn/StdOut/StdErr
1903 * Updated layout of sysamiga.pas
1905 Revision 1.3 1998/01/24 21:09:53 carl
1906 + added missing input/output function pointers
1908 Revision 1.2 1998/01/24 14:08:25 carl
1909 * RunError 217 --> RunError 219 (cannot open lib)
1910 + Standard Handle names implemented
1912 Revision 1.1 1998/01/24 05:12:15 carl
1913 + initial revision, some stuff still missing though.
1914 (and as you might imagine ... untested :))