freepascal.compiler/rtl/os2/sysos2.pas

{****************************************************************************

					 FPK-Pascal -- OS/2 runtime library

				  Copyright (c) 1993,95 by Florian Kl„mpfl
				   Copyright (c) 1997 by Dani‰l Mantione

 FPK-Pascal is distributed under the GNU Public License v2. So is this unit.
 The GNU Public License requires you to distribute the source code of this
 unit with any product that uses it. We grant you an exception to this, and
 that is, when you compile a program with the FPK Pascal compiler, you do not
 need to ship source code with that program, AS LONG AS YOU ARE USING
 UNMODIFIED CODE! If you modify this code, you MUST change the next line:

 <This an official, unmodified FPK Pascal source code file.>

 Send us your modified files, we can work together if you want!

 FPK-Pascal 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.  See the
 Library GNU General Public License for more details.

 You should have received a copy of the Library GNU General Public License
 along with FPK-Pascal; see the file COPYING.LIB.  If not, write to
 the Free Software Foundation, 59 Temple Place - Suite 330,
 Boston, MA 02111-1307, USA.

****************************************************************************}

unit sysos2;

{Changelog:

	People:

		DM - Dani‰l Mantione

	Date:			Description of change:				Changed by:

	 -				First released version 0.1.			DM

Coding style:

	My coding style is a bit unusual for Pascal. Nevertheless I friendly ask
	you to try to make your changes not look all to different. In general,
	set your IDE to use tab characters, optimal fill on and a tabsize of 4.}

{$I os.inc}

interface

{Link the startup code.}
{$l prt1.oo2}

{$I	SYSTEMH.INC}
{$I	heaph.inc}

type	Tos=(osDOS,osOS2,osDPMI);

var		os_mode:Tos;
		first_meg:pointer;

type	Psysthreadib=^Tsysthreadib;
		Pthreadinfoblock=^Tthreadinfoblock;
		Pprocessinfoblock=^Tprocessinfoblock;

		Tbytearray=array[0..$ffff] of byte;
		Pbytearray=^Tbytearray;

		Tsysthreadib=record
			tid,
			priority,
			version:longint;
			MCcount,
			MCforceflag:word;
		end;

		Tthreadinfoblock=record
			pexchain,
			stack,
			stacklimit:pointer;
			tib2:Psysthreadib;
			version,
			ordinal:longint;
		end;

		Tprocessinfoblock=record
			pid,
			parentpid,
			hmte:longint;
			cmd,
			env:Pbytearray;
			flstatus,
			ttype:longint;
		end;

const	UnusedHandle=$ffff;
		StdInputHandle=0;
		StdOutputHandle=1;
		StdErrorHandle=2;

implementation

{$I	SYSTEM.INC}

procedure dosgetinfoblocks(var Atib:Pthreadinfoblock;
						   var Apib:Pprocessinfoblock);
						   external 'DOSCALLS' index 312;

{This is the correct way to call external assembler procedures.}
procedure syscall;external name '___SYSCALL';

{***************************************************************************

				Runtime error checking related routines.

***************************************************************************}

{$S-}
procedure st1(stack_size:longint);[public,alias: 'STACKCHECK'];

begin
	{ called when trying to get local stack }
	{ if the compiler directive $S is set   }
	asm
		movl stack_size,%ebx
		movl %esp,%eax
		subl %ebx,%eax
{$ifdef SYSTEMDEBUG}
		movl U_SYSOS2_LOWESTSTACK,%ebx
		cmpl %eax,%ebx
		jb   .Lis_not_lowest
		movl %eax,U_SYSOS2_LOWESTSTACK
	.Lis_not_lowest:
{$endif SYSTEMDEBUG}
		cmpb $2,U_SYSOS2_OS_MODE
		jne .Lrunning_in_dos
		movl U_SYSOS2_STACKBOTTOM,%ebx
		jmp .Lrunning_in_os2
	.Lrunning_in_dos:
		movl __heap_brk,%ebx
	.Lrunning_in_os2:
		cmpl %eax,%ebx
		jae  .Lshort_on_stack
		leave
		ret  $4
	.Lshort_on_stack:
	end ['EAX','EBX'];
	{ this needs a local variable }
	{ so the function called itself !! }
	{ Writeln('low in stack ');}
	RunError(202);
end;
{no stack check in system }

{****************************************************************************

					Miscelleanious related routines.

****************************************************************************}

procedure halt(errnum:byte);

begin
	asm
		movb $0x4c,%ah
		movb errnum,%al
		call syscall
	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 _argv,%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
		call syscall
		movw %cx,-4(%ebp)
		movw %dx,-2(%ebp)
	end;
	randseed:=hl;
end;

{****************************************************************************

					Heap management releated routines.

****************************************************************************}


{ this function allows to extend the heap by calling
syscall $7f00 resizes the brk area}

function sbrk(size:longint):longint;

begin
	asm
		movl size,%edx
		movw $0x7f00,%ax
		call syscall
		movl %eax,__RESULT
	end;
end;

function getheapstart:pointer;

begin
	asm
		movl __heap_base,%eax
		leave
		ret
	end ['EAX'];
end;

{$i	heap.inc}

{****************************************************************************

						  Low Level File Routines

****************************************************************************}

procedure allowslash(p:Pchar);

{Allow slash as backslash.}

var	i:longint;

begin
	for i:=0 to strlen(p) do
		if p[i]='/' then p[i]:='\';
end;

procedure do_close(h:longint);

begin
	 asm
		movb $0x3e,%ah
		mov	h,%ebx
		call syscall
	 end;
end;

procedure do_erase(p:Pchar);

begin
	allowslash(p);
	asm
		movl 8(%ebp),%edx
		movb $0x41,%ah
		call syscall
		jnc	.LERASE1
		movw %ax,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
		call syscall
		jnc	.LRENAME1
		movw %ax,inoutres;
	.LRENAME1:
	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
		call syscall
		jnc	.LDOSREAD1
		movw %ax,inoutres;
		xorl %eax,%eax
	.LDOSREAD1:
		leave
		ret	$12
	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
		call syscall
		jnc	.LDOSWRITE1
		movw %ax,inoutres;
	.LDOSWRITE1:
	   movl %eax,-4(%ebp)
	end;
end;

function do_filepos(handle:longint):longint;

begin
	asm
		movw $0x4201,%ax
		movl 8(%ebp),%ebx
		xorl %edx,%edx
		call syscall
		jnc	.LDOSFILEPOS
		movw %ax,inoutres;
		xorl %eax,%eax
	.LDOSFILEPOS:
		leave
		ret	$4
	 end;
end;

procedure do_seek(handle,pos:longint);

begin
	asm
		movw $0x4200,%ax
		movl 8(%ebp),%ebx
		movl 12(%ebp),%edx
		call syscall
		jnc .LDOSSEEK1
		movw %ax,inoutres;
	.LDOSSEEK1:
		leave
		ret $8
	end;
end;

function do_seekend(handle:longint):longint;

begin
	asm
		movw $0x4202,%ax
		movl 8(%ebp),%ebx
		xorl %edx,%edx
		call syscall
		jnc .Lset_at_end1
		movw %ax,inoutres;
		xorl %eax,%eax
	.Lset_at_end1:
		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
		call syscall
		jc .LTruncate1
		movl 8(%ebp),%ebx
		movl 12(%ebp),%edx
		movl %ebp,%edx
		xorl %ecx,%ecx
		movb $0x40,%ah
		call syscall
		jnc .LTruncate2
		.LTruncate1:
		movw %ax,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:byte;

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:=high(word);
	oflags:=2;
	{ convert filemode to filerec modes }
	case (flags and 3) of
		0 : begin
			filerec(f).mode:=fminput;
			oflags:=0;
		end;
		1 : filerec(f).mode:=fmoutput;
		2 : filerec(f).mode:=fminout;
	end;
	if (flags and $100)<>0 then
		begin
			filerec(f).mode:=fmoutput;
			oflags:=2;
		end
	else
		if (flags and $10)<>0 then
			begin
				filerec(f).mode:=fmoutput;
				oflags:=2;
			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;
	if (flags and $100)<>0 then
		{Use create function.}
		asm
			movb $0x3c,%ah
			movl p,%edx
			xorw %cx,%cx
			call syscall
			jnc .LOPEN1
			movw %ax,inoutres;
			movw $0xffff,%ax
		.LOPEN1:
			movl f,%edx
			movw %ax,(%edx)
		end
	else
		{Use open function.}
		asm
			movb $0x3d,%ah
			movb oflags,%al
			movl p,%edx
			call syscall
			jnc .LOPEN2
			movw %ax,inoutres;
			movw $0xffff,%ax
		.LOPEN2:
			movl f,%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 related routines.

****************************************************************************}

{*****************************************************************************
						   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
		call syscall
		jnc  .LDOS_DIRS1
		movw %ax,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;

procedure getdir(drivenr : byte;var dir : string);

{Written by Michael Van Canneyt.}

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
		call syscall
	end;
	{ Now Dir should be filled with directory in ASCIIZ, }
	{ starting from dir[4]                               }
	dir[0]:=#3;
	dir[2]:=':';
	dir[3]:='\';
	i:=4;
	{Conversion to Pascal string }
	while (dir[i]<>#0) do
		begin
			{ convert path name to DOS }
			if dir[i]='/' then
			dir[i]:='\';
			dir[0]:=char(i);
			inc(i);
		end;
	{ upcase the string (FPKPascal function) }
	dir:=upcase(dir);
	if drivenr<>0 then   { Drive was supplied. We know it }
		dir[1]:=char(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
				call syscall
				addb $65,%al
				movb %al,i
			end;
			dir[1]:=char(i);
		end;
end;



{****************************************************************************

						System unit 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;

var	pib:Pprocessinfoblock;
	tib:Pthreadinfoblock;

begin
	{Determine the operating system	we are running on.}
	asm
		movw $0x7f0a,%ax
		call syscall
		testw $512,%bx		   {Bit 9 is OS/2 flag.}
		setnzl os_mode
		testw $4096,%bx
		jz .LnoRSX
		movl $2,os_mode
	.LnoRSX:
	end;

	{$ASMMODE DIRECT}
	{Enable the brk area by initializing it with the initial heap size.}
	asm
		movw $0x7f01,%ax
		movl HEAPSIZE,%edx
		addl __heap_base,%edx
		call ___SYSCALL
		cmpl $-1,%eax
		jnz Lheapok
		pushl $204
		{call RUNERROR$$WORD}
	Lheapok:
	end;
	{$ASMMODE ATT}

	{Now request, if we	are	running	under DOS,
	 read-access to	the	first meg. of memory.}
	if os_mode in [osDOS,osDPMI] then
		asm
			movw $0x7f13,%ax
			xorl %ebx,%ebx
			movl $0xfff,%ecx
			xorl %edx,%edx
			call syscall
			movl %eax,first_meg
		end
	else
		first_meg:=nil;
	{At 0.9.2, case for enumeration does not work.}
	case os_mode of
		osDOS:
			stackbottom:=0;		{In DOS mode, heap_brk is also the
								 stack bottom.}
		osOS2:
			begin
				dosgetinfoblocks(tib,pib);
				stackbottom:=longint(tib^.stack);
			end;
		osDPMI:
			stackbottom:=0;		{Not sure how to get it, but seems to be
								 always zero.}
	end;
	exitproc:=nil;

	{Initialize the heap.}
	initheap;

	{ to test stack depth }
	loweststack:=maxlongint;

	OpenStdIO(Input,fmInput,StdInputHandle);
	OpenStdIO(Output,fmOutput,StdOutputHandle);
	OpenStdIO(StdErr,fmOutput,StdErrorHandle);

	{ kein Ein-	Ausgabefehler }
	inoutres:=0;
end.