123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682 |
- {
- $Id$
- This file is part of the Free Pascal run time library.
- Copyright (c) 1993,97 by Florian Klaempfl,
- member of the Free Pascal development team.
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- { system unit for go32v1 }
- {$define DOS}
- unit system;
- {$I os.inc}
- interface
- { die betriebssystemunabhangigen Deklarationen einfuegen: }
- {$I systemh.inc}
- {$I heaph.inc}
- const
- UnusedHandle=$ffff;
- StdInputHandle=0;
- StdOutputHandle=1;
- StdErrorHandle=2;
- type
- {$PACKRECORDS 1}
- t_stub_info = record
- magic : array[0..15] of char;
- size : longint;
- minstack : longint;
- memory_handle : longint;
- initial_size : longint;
- minkeep : word;
- ds_selector : word;
- ds_segment : word;
- psp_selector : word;
- cs_selector : word;
- env_size : word;
- basename : array[0..7] of char;
- argv0 : array [0..15] of char;
- dpmi_server : array [0..15] of char;
- end;
- p_stub_info = ^t_stub_info;
- t_go32_info_block = record
- size_of_this_structure_in_bytes : longint; {offset 0}
- linear_address_of_primary_screen : longint; {offset 4}
- linear_address_of_secondary_screen : longint; {offset 8}
- linear_address_of_transfer_buffer : longint; {offset 12}
- size_of_transfer_buffer : longint; {offset 16}
- pid : longint; {offset 20}
- master_interrupt_controller_base : byte; {offset 24}
- slave_interrupt_controller_base : byte; {offset 25}
- selector_for_linear_memory : word; {offset 26}
- linear_address_of_stub_info_structure : longint; {offset 28}
- linear_address_of_original_psp : longint; {offset 32}
- run_mode : word; {offset 36}
- run_mode_info : word; {offset 38}
- end;
- {$PACKRECORDS NORMAL}
- var
- stub_info : p_stub_info;
- go32_info_block : t_go32_info_block;
- environ : ppchar;
- implementation
- { include system independent routines }
- {$I system.inc}
- {$S-}
- procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
- begin
- { called when trying to get local stack }
- { if the compiler directive $S is set }
- { this function must preserve esi !!!! }
- { because esi is set by the calling }
- { proc for methods }
- { it must preserve all registers !! }
- asm
- pushl %eax
- pushl %ebx
- movl stack_size,%ebx
- movl %esp,%eax
- subl %ebx,%eax
- {$ifdef SYSTEMDEBUG}
- movl U_SYSTEM_LOWESTSTACK,%ebx
- cmpl %eax,%ebx
- jb _is_not_lowest
- movl %eax,U_SYSTEM_LOWESTSTACK
- _is_not_lowest:
- {$endif SYSTEMDEBUG}
- movl __stkbottom,%ebx
- cmpl %eax,%ebx
- jae __short_on_stack
- popl %ebx
- popl %eax
- leave
- ret $4
- __short_on_stack:
- { can be usefull for error recovery !! }
- popl %ebx
- popl %eax
- end['EAX','EBX'];
- RunError(202);
- { this needs a local variable }
- { so the function called itself !! }
- { Writeln('low in stack ');
- RunError(202); }
- end;
- procedure halt(errnum : byte);
- begin
- do_exit;
- flush(stderr);
- asm
- movl $0x4c00,%eax
- movb 8(%ebp),%al
- int $0x21
- end;
- end;
- function paramcount : longint;
- begin
- asm
- movl _argc,%eax
- decl %eax
- leave
- ret
- end ['EAX'];
- end;
- function paramstr(l : longint) : string;
- function args : pointer;
- begin
- asm
- movl _args,%eax
- leave
- ret
- end ['EAX'];
- end;
- var
- p : ^pchar;
- begin
- if (l>=0) and (l<=paramcount) then
- begin
- p:=args;
- paramstr:=strpas(p[l]);
- end
- else paramstr:='';
- end;
- procedure randomize;
- var
- hl : longint;
- begin
- asm
- movb $0x2c,%ah
- int $0x21
- movw %cx,-4(%ebp)
- movw %dx,-2(%ebp)
- end;
- randseed:=hl;
- end;
- { use standard heap management }
- { sbrk function of go32v1 }
- function Sbrk(size : longint) : longint;
- begin
- asm
- movl size,%ebx
- movl $0x4a01,%eax
- int $0x21
- movl %eax,__RESULT
- end;
- end;
- {$I heap.inc}
- {****************************************************************************
- Low Level File Routines
- ****************************************************************************}
- procedure AllowSlash(p:pchar);
- var
- i : longint;
- begin
- { allow slash as backslash }
- for i:=0 to strlen(p) do
- if p[i]='/' then p[i]:='\';
- end;
- procedure do_close(h : longint);
- begin
- asm
- movl 8(%ebp),%ebx
- movb $0x3e,%ah
- pushl %ebp
- intl $0x21
- popl %ebp
- end;
- end;
- procedure do_erase(p : pchar);
- begin
- AllowSlash(p);
- asm
- movl 8(%ebp),%edx
- movb $0x41,%ah
- pushl %ebp
- int $0x21
- popl %ebp
- jnc .LERASE1
- movw %ax,U_SYSTEM_INOUTRES;
- .LERASE1:
- end;
- end;
- procedure do_rename(p1,p2 : pchar);
- begin
- AllowSlash(p1);
- AllowSlash(p2);
- asm
- movl 8(%ebp),%edx
- movl 12(%ebp),%edi
- movb $0x56,%ah
- pushl %ebp
- int $0x21
- popl %ebp
- jnc .LRENAME1
- movw %ax,U_SYSTEM_INOUTRES;
- .LRENAME1:
- end;
- end;
- function do_write(h,addr,len : longint) : longint;
- begin
- asm
- movl 16(%ebp),%ecx
- movl 12(%ebp),%edx
- movl 8(%ebp),%ebx
- movb $0x40,%ah
- int $0x21
- jnc .LDOSWRITE1
- movw %ax,U_SYSTEM_INOUTRES;
- .LDOSWRITE1:
- movl %eax,-4(%ebp)
- end;
- end;
- function do_read(h,addr,len : longint) : longint;
- begin
- asm
- movl 16(%ebp),%ecx
- movl 12(%ebp),%edx
- movl 8(%ebp),%ebx
- movb $0x3f,%ah
- int $0x21
- jnc .LDOSREAD1
- movw %ax,U_SYSTEM_INOUTRES;
- xorl %eax,%eax
- .LDOSREAD1:
- leave
- ret $12
- end;
- end;
- function do_filepos(handle : longint) : longint;
- begin
- asm
- movb $0x42,%ah
- movb $0x1,%al
- movl 8(%ebp),%ebx
- xorl %ecx,%ecx
- xorl %edx,%edx
- pushl %ebp
- int $0x21
- popl %ebp
- jnc .LDOSFILEPOS1
- movw %ax,U_SYSTEM_INOUTRES;
- xorl %eax,%eax
- jmp .LDOSFILEPOS2
- .LDOSFILEPOS1:
- shll $16,%edx
- movzwl %ax,%eax
- orl %edx,%eax
- .LDOSFILEPOS2:
- leave
- ret $4
- end;
- end;
- procedure do_seek(handle,pos : longint);
- begin
- asm
- movl $0x4200,%eax
- movl 8(%ebp),%ebx
- movl 12(%ebp),%edx
- movl %edx,%ecx
- shrl $16,%ecx
- pushl %ebp
- int $0x21
- popl %ebp
- jnc .LDOSSEEK1
- movw %ax,U_SYSTEM_INOUTRES;
- .LDOSSEEK1:
- leave
- ret $8
- end;
- end;
- function do_seekend(handle : longint) : longint;
- begin
- asm
- movl $0x4202,%eax
- movl 8(%ebp),%ebx
- xorl %ecx,%ecx
- xorl %edx,%edx
- pushl %ebp
- int $0x21
- popl %ebp
- jnc .Lset_at_end1
- movw %ax,U_SYSTEM_INOUTRES;
- xorl %eax,%eax
- jmp .Lset_at_end2
- .Lset_at_end1:
- shll $16,%edx
- movzwl %ax,%eax
- orl %edx,%eax
- .Lset_at_end2:
- leave
- ret $4
- end;
- end;
- function do_filesize(handle : longint) : longint;
- var
- aktfilepos : longint;
- begin
- aktfilepos:=do_filepos(handle);
- do_filesize:=do_seekend(handle);
- do_seek(handle,aktfilepos);
- end;
- procedure do_truncate(handle,pos : longint);
- begin
- asm
- movl $0x4200,%eax
- movl 8(%ebp),%ebx
- movl 12(%ebp),%edx
- movl %edx,%ecx
- shrl $16,%ecx
- pushl %ebp
- int $0x21
- popl %ebp
- jc .LTruncate1
- movl 8(%ebp),%ebx
- movl 12(%ebp),%edx
- movl %ebp,%edx
- xorl %ecx,%ecx
- movb $0x40,%ah
- int $0x21
- jnc .LTruncate2
- .LTruncate1:
- movw %ax,U_SYSTEM_INOUTRES;
- .LTruncate2:
- leave
- ret $8
- end;
- end;
- procedure do_open(var f;p:pchar;flags:longint);
- {
- filerec and textrec have both handle and mode as the first items so
- they could use the same routine for opening/creating.
- when (flags and $10) the file will be append
- when (flags and $100) the file will be truncate/rewritten
- when (flags and $1000) there is no check for close (needed for textfiles)
- }
- var
- oflags : longint;
- begin
- AllowSlash(p);
- { close first if opened }
- if ((flags and $1000)=0) then
- begin
- case filerec(f).mode of
- fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
- fmclosed : ;
- else
- begin
- inoutres:=102; {not assigned}
- exit;
- end;
- end;
- end;
- { reset file handle }
- filerec(f).handle:=UnusedHandle;
- oflags:=$8404;
- { convert filemode to filerec modes }
- case (flags and 3) of
- 0 : begin
- filerec(f).mode:=fminput;
- oflags:=$8001;
- end;
- 1 : filerec(f).mode:=fmoutput;
- 2 : filerec(f).mode:=fminout;
- end;
- if (flags and $100)<>0 then
- begin
- filerec(f).mode:=fmoutput;
- oflags:=$8302;
- end
- else
- if (flags and $10)<>0 then
- begin
- filerec(f).mode:=fmoutput;
- oflags:=$8404;
- end;
- { empty name is special }
- if p[0]=#0 then
- begin
- case filerec(f).mode of
- fminput : filerec(f).handle:=StdInputHandle;
- fmappend,
- fmoutput : begin
- filerec(f).handle:=StdOutputHandle;
- filerec(f).mode:=fmoutput; {fool fmappend}
- end;
- end;
- exit;
- end;
- asm
- movl $0xff02,%ax
- movl -4(%ebp),%ecx
- movl 12(%ebp),%ebx
- int $0x21
- jnc .LOPEN1
- movw %ax,U_SYSTEM_INOUTRES;
- movw $0xffff,%ax
- .LOPEN1:
- movl 8(%ebp),%edx
- movw %ax,(%edx)
- end;
- if (flags and $10)<>0 then
- do_seekend(filerec(f).handle);
- end;
- {*****************************************************************************
- UnTyped File Handling
- *****************************************************************************}
- {$i file.inc}
- {*****************************************************************************
- Typed File Handling
- *****************************************************************************}
- {$i typefile.inc}
- {*****************************************************************************
- Text File Handling
- *****************************************************************************}
- {$DEFINE EOF_CTRLZ}
- {$i text.inc}
- {*****************************************************************************
- Directory Handling
- *****************************************************************************}
- procedure DosDir(func:byte;const s:string);
- var
- buffer : array[0..255] of char;
- begin
- move(s[1],buffer,length(s));
- buffer[length(s)]:=#0;
- AllowSlash(pchar(@buffer));
- asm
- leal buffer,%edx
- movb 8(%ebp),%ah
- int $0x21
- jnc .LDOS_DIRS1
- movw %ax,U_SYSTEM_INOUTRES;
- .LDOS_DIRS1:
- end;
- end;
- procedure mkdir(const s : string);
- begin
- DosDir($39,s);
- end;
- procedure rmdir(const s : string);
- begin
- DosDir($3a,s);
- end;
- procedure chdir(const s : string);
- begin
- DosDir($3b,s);
- end;
- { thanks to Michael Van Canneyt <[email protected]>, }
- { who writes this code }
- { her is a problem if the getdir is called with a pathstr var in dos.pp }
- procedure getdir(drivenr : byte;var dir : string);
- var
- temp : array[0..255] of char;
- sof : pchar;
- i : byte;
- begin
- sof:=pchar(@dir[4]);
- { dir[1..3] will contain '[drivenr]:\', but is not }
- { supplied by DOS, so we let dos string start at }
- { dir[4] }
- { Get dir from drivenr : 0=default, 1=A etc... }
- asm
- movb drivenr,%dl
- movl sof,%esi
- mov $0x47,%ah
- int $0x21
- end;
- { Now Dir should be filled with directory in ASCIIZ, }
- { starting from dir[4] }
- dir[0]:=#3;
- dir[2]:=':';
- dir[3]:='\';
- i:=4;
- { conversation to Pascal string }
- while (dir[i]<>#0) do
- begin
- { convert path name to DOS }
- if dir[i]='/' then
- dir[i]:='\';
- dir[0]:=chr(i);
- inc(i);
- end;
- { upcase the string (FPKPascal function) }
- dir:=upcase(dir);
- if drivenr<>0 then { Drive was supplied. We know it }
- dir[1]:=chr(65+drivenr-1)
- else
- begin
- { We need to get the current drive from DOS function 19H }
- { because the drive was the default, which can be unknown }
- asm
- movb $0x19,%ah
- int $0x21
- addb $65,%al
- movb %al,i
- end;
- dir[1]:=chr(i);
- end;
- end;
- {*****************************************************************************
- SystemUnit Initialization
- *****************************************************************************}
- procedure OpenStdIO(var f:text;mode:word;hdl:longint);
- begin
- Assign(f,'');
- TextRec(f).Handle:=hdl;
- TextRec(f).Mode:=mode;
- TextRec(f).InOutFunc:=@FileInOutFunc;
- TextRec(f).FlushFunc:=@FileInOutFunc;
- TextRec(f).Closefunc:=@fileclosefunc;
- end;
- Begin
- { Initialize ExitProc }
- ExitProc:=Nil;
- { to test stack depth }
- loweststack:=maxlongint;
- { Setup heap }
- InitHeap;
- { Setup stdin, stdout and stderr }
- OpenStdIO(Input,fmInput,StdInputHandle);
- OpenStdIO(Output,fmOutput,StdOutputHandle);
- OpenStdIO(StdErr,fmOutput,StdErrorHandle);
- { Reset IO Error }
- InOutRes:=0;
- End.
- {
- $Log$
- Revision 1.2 1998-03-26 12:21:02 peter
- * makefile works again
- * environ is now defined in system.pp (like go32v2)
- Revision 1.1.1.1 1998/03/25 11:18:41 root
- * Restored version
- Revision 1.9 1998/02/14 01:41:35 peter
- * fixed unusedhandle bug which was -1
- Revision 1.8 1998/01/26 11:57:03 michael
- + Added log at the end
- Working file: rtl/dos/go32v1/system.pp
- description:
- ----------------------------
- revision 1.7
- date: 1998/01/25 21:53:22; author: peter; state: Exp; lines: +12 -8
- + Universal Handles support for StdIn/StdOut/StdErr
- * Updated layout of sysamiga.pas
- ----------------------------
- revision 1.6
- date: 1998/01/16 23:10:50; author: florian; state: Exp; lines: +2 -2
- + some tobject stuff
- ----------------------------
- revision 1.5
- date: 1998/01/11 02:47:31; author: michael; state: Exp; lines: +384 -507
- * Changed files to use the new filestructure in /inc directory.
- (By Peter Vreman)
- ----------------------------
- revision 1.4
- date: 1998/01/07 00:05:04; author: michael; state: Exp; lines: +189 -184
- + Final adjustments for a uniform file handling interface.
- (From Peter Vreman)
- ----------------------------
- revision 1.3
- date: 1998/01/05 16:51:04; author: michael; state: Exp; lines: +18 -46
- + Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
- ----------------------------
- revision 1.2
- date: 1997/12/01 12:24:06; author: michael; state: Exp; lines: +12 -3
- + added copyright reference in header.
- ----------------------------
- revision 1.1
- date: 1997/11/27 08:33:53; author: michael; state: Exp;
- Initial revision
- ----------------------------
- revision 1.1.1.1
- date: 1997/11/27 08:33:53; author: michael; state: Exp; lines: +0 -0
- FPC RTL CVS start
- =============================================================================
- }
|