paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-23 19:49:46 +02:00
Code Issues Packages Projects Releases Wiki Activity

- remove go32v1 support

Browse Source
This commit is contained in:
carl 2002-03-28 20:58:10 +00:00
parent fc1b705950
commit b585c841b1
14 changed files with 0 additions and 5811 deletions

3
install/man/man1/fpc.1
View File

@ -430,9 +430,6 @@ Specifies the target operating system.
can be one of the following:
.RS
.TP
.I GO32V1
DOS and version 1 of the DJ DELORIE extender (no longer maintained).
.TP
.I GO32V2
DOS and version 2 of the DJ DELORIE extender.
.TP

3
install/man/man1/ppc386.1
View File

@ -436,9 +436,6 @@ Specifies the target operating system.
can be one of the following:
.RS
.TP
.I GO32V1
DOS and version 1 of the DJ DELORIE extender (no longer maintained).
.TP
.I GO32V2
DOS and version 2 of the DJ DELORIE extender.
.TP

1171
rtl/go32v1/Makefile
View File

File diff suppressed because it is too large Load Diff

144
rtl/go32v1/Makefile.fpc
View File

@ -1,144 +0,0 @@
#
# Makefile.fpc for Go32v1 RTL
#
[package]
main=rtl
[target]
loaders=prt0
units=$(SYSTEMUNIT) objpas strings \
go32 \
dos crt objects printer \
sysutils math typinfo \
cpu mmx getopts heaptrc \
msmouse
[require]
nortl=y
[install]
fpcpackage=y
[default]
fpcdir=../..
target=go32v1
cpu=i386
[compiler]
includedir=$(INC) $(PROCINC)
sourcedir=$(INC) $(PROCINC)
targetdir=.
[prerules]
RTL=..
INC=../inc
PROCINC=../$(CPU_TARGET)
# Use new feature from 1.0.5 version
# that generates release PPU files
# which will not be recompiled
ifdef RELEASE
override FPCOPT+=-Ur
endif
# Paths
OBJPASDIR=$(RTL)/objpas
GRAPHDIR=$(INC)/graph
# Define Go32v2 Units
SYSTEMUNIT=system
[rules]
SYSTEMPPU=$(addsuffix $(PPUEXT),$(SYSTEMUNIT))
# Get the system independent include file names.
# This will set the following variables :
# SYSINCNAMES
include $(INC)/makefile.inc
SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES))
# Get the processor dependent include file names.
# This will set the following variables :
# CPUINCNAMES
include $(PROCINC)/makefile.cpu
SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES))
# Put system unit dependencies together.
SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS)
#
# Loaders
#
prt0$(OEXT) : prt0.as
$(AS) -o prt0$(OEXT) prt0.as
#
# Base Units (System, strings, os-dependent-base-unit)
#
system$(PPUEXT) : system.pp $(SYSDEPS)
$(COMPILER) -Us -Sg system.pp
objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc system$(PPUEXT)
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp
strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc \
$(PROCINC)/strings.inc $(PROCINC)/stringss.inc \
system$(PPUEXT)
#
# System Dependent Units
#
go32$(PPUEXT) : go32.pp objpas$(PPUEXT) system$(PPUEXT)
#
# TP7 Compatible RTL Units
#
dos$(PPUEXT) : dos.pp $(INC)/filerec.inc $(INC)/textrec.inc \
go32$(PPUEXT) strings$(PPUEXT) system$(PPUEXT)
crt$(PPUEXT) : crt.pp $(INC)/textrec.inc go32$(PPUEXT) system$(PPUEXT)
objects$(PPUEXT) : $(INC)/objects.pp objinc.inc system$(PPUEXT)
printer$(PPUEXT) : printer.pp system$(PPUEXT)
#
# Delphi Compatible Units
#
sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
filutil.inc disk.inc objpas$(PPUEXT) dos$(PPUEXT) go32$(PPUEXT)
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/math.pp
#
# Other system-independent RTL Units
#
cpu$(PPUEXT) : $(PROCINC)/cpu.pp system$(PPUEXT)
mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) system$(PPUEXT)
getopts$(PPUEXT) : $(INC)/getopts.pp system$(PPUEXT)
heaptrc$(PPUEXT) : $(INC)/heaptrc.pp system$(PPUEXT)
$(COMPILER) -Sg $(INC)/heaptrc.pp
#
# Other system-dependent RTL Units
#
msmouse$(PPUEXT) : msmouse.pp system$(PPUEXT)

821
rtl/go32v1/crt.pp
View File

@ -1,821 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team.
Borland Pascal 7 Compatible CRT Unit for Go32V1 and Go32V2
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.
**********************************************************************}
unit crt;
interface
const
{ CRT modes }
BW40 = 0; { 40x25 B/W on Color Adapter }
CO40 = 1; { 40x25 Color on Color Adapter }
BW80 = 2; { 80x25 B/W on Color Adapter }
CO80 = 3; { 80x25 Color on Color Adapter }
Mono = 7; { 80x25 on Monochrome Adapter }
Font8x8 = 256; { Add-in for ROM font }
{ Mode constants for 3.0 compatibility }
C40 = CO40;
C80 = CO80;
{ Foreground and background color constants }
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
{ Foreground color constants }
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{ Add-in for blinking }
Blink = 128;
var
{ Interface variables }
CheckBreak: Boolean; { Enable Ctrl-Break }
CheckEOF: Boolean; { Enable Ctrl-Z }
DirectVideo: Boolean; { Enable direct video addressing }
CheckSnow: Boolean; { Enable snow filtering }
LastMode: Word; { Current text mode }
TextAttr: Byte; { Current text attribute }
WindMin: Word; { Window upper left coordinates }
WindMax: Word; { Window lower right coordinates }
{ Interface procedures }
procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: Char;
procedure TextMode(Mode: Integer);
procedure Window(X1,Y1,X2,Y2: Byte);
procedure GotoXY(X,Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Word);
procedure Sound(Hz: Word);
procedure NoSound;
{Extra Functions}
procedure cursoron;
procedure cursoroff;
procedure cursorbig;
implementation
uses
go32;
{$ASMMODE ATT}
var
DelayCnt, { don't modify this var name, as it is hard coded }
ScreenWidth,
ScreenHeight : longint;
{
definition of textrec is in textrec.inc
}
{$i textrec.inc}
{****************************************************************************
Low level Routines
****************************************************************************}
procedure setscreenmode(mode : byte);
begin
asm
movb 8(%ebp),%al
xorb %ah,%ah
pushl %ebp
int $0x10
popl %ebp
end;
end;
function GetScreenHeight : longint;
begin
dosmemget($40,$84,getscreenheight,1);
inc(getscreenheight);
end;
function GetScreenWidth : longint;
begin
dosmemget($40,$4a,getscreenwidth,1);
end;
procedure SetScreenCursor(x,y : longint);
begin
asm
movb $0x02,%ah
movb $0,%bh
movb y,%dh
movb x,%dl
subw $0x0101,%dx
pushl %ebp
int $0x10
popl %ebp
end;
end;
procedure GetScreenCursor(var x,y : longint);
begin
x:=0;
y:=0;
dosmemget($40,$50,x,1);
dosmemget($40,$51,y,1);
inc(x);
inc(y);
end;
{****************************************************************************
Helper Routines
****************************************************************************}
Function WinMinX: Byte;
{
Current Minimum X coordinate
}
Begin
WinMinX:=(WindMin and $ff)+1;
End;
Function WinMinY: Byte;
{
Current Minimum Y Coordinate
}
Begin
WinMinY:=(WindMin shr 8)+1;
End;
Function WinMaxX: Byte;
{
Current Maximum X coordinate
}
Begin
WinMaxX:=(WindMax and $ff)+1;
End;
Function WinMaxY: Byte;
{
Current Maximum Y coordinate;
}
Begin
WinMaxY:=(WindMax shr 8) + 1;
End;
Function FullWin:boolean;
{
Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines
}
begin
FullWin:=(WinMinX=1) and (WinMinY=1) and
(WinMaxX=ScreenWidth) and (WinMaxY=ScreenHeight);
end;
{****************************************************************************
Public Crt Functions
****************************************************************************}
procedure textmode(mode : integer);
begin
lastmode:=mode;
mode:=mode and $ff;
setscreenmode(mode);
screenwidth:=getscreenwidth;
screenheight:=getscreenheight;
windmin:=0;
windmax:=(screenwidth-1) or ((screenheight-1) shl 8);
end;
Procedure TextColor(Color: Byte);
{
Switch foregroundcolor
}
Begin
TextAttr:=(Color and $f) or (TextAttr and $70);
If (Color>15) Then TextAttr:=TextAttr Or Blink;
End;
Procedure TextBackground(Color: Byte);
{
Switch backgroundcolor
}
Begin
TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
End;
Procedure HighVideo;
{
Set highlighted output.
}
Begin
TextColor(TextAttr Or $08);
End;
Procedure LowVideo;
{
Set normal output
}
Begin
TextColor(TextAttr And $77);
End;
Procedure NormVideo;
{
Set normal back and foregroundcolors.
}
Begin
TextColor(7);
TextBackGround(0);
End;
Procedure GotoXy(X: Byte; Y: Byte);
{
Go to coordinates X,Y in the current window.
}
Begin
If (X>0) and (X<=WinMaxX- WinMinX+1) and
(Y>0) and (Y<=WinMaxY-WinMinY+1) Then
Begin
Inc(X,WinMinX-1);
Inc(Y,WinMinY-1);
SetScreenCursor(x,y);
End;
End;
Procedure Window(X1, Y1, X2, Y2: Byte);
{
Set screen window to the specified coordinates.
}
Begin
if (X1>X2) or (X2>ScreenWidth) or
(Y1>Y2) or (Y2>ScreenHeight) then
exit;
WindMin:=((Y1-1) Shl 8)+(X1-1);
WindMax:=((Y2-1) Shl 8)+(X2-1);
GoToXY(1,1);
End;
Procedure ClrScr;
{
Clear the current window, and set the cursor on 1,1
}
var
fil : word;
y : longint;
begin
fil:=32 or (textattr shl 8);
if FullWin then
DosmemFillWord($b800,0,ScreenHeight*ScreenWidth,fil)
else
begin
for y:=WinMinY to WinMaxY do
DosmemFillWord($b800,((y-1)*ScreenWidth+(WinMinX-1))*2,WinMaxX-WinMinX+1,fil);
end;
Gotoxy(1,1);
end;
Procedure ClrEol;
{
Clear from current position to end of line.
}
var
x,y : longint;
fil : word;
Begin
GetScreenCursor(x,y);
fil:=32 or (textattr shl 8);
if x<WinMaxX then
DosmemFillword($b800,((y-1)*ScreenWidth+(x-1))*2,WinMaxX-x+1,fil);
End;
Function WhereX: Byte;
{
Return current X-position of cursor.
}
var
x,y : longint;
Begin
GetScreenCursor(x,y);
WhereX:=x-WinMinX+1;
End;
Function WhereY: Byte;
{
Return current Y-position of cursor.
}
var
x,y : longint;
Begin
GetScreenCursor(x,y);
WhereY:=y-WinMinY+1;
End;
{*************************************************************************
KeyBoard
*************************************************************************}
var
is_last : boolean;
last : char;
function readkey : char;
var
char2 : char;
char1 : char;
begin
if is_last then
begin
is_last:=false;
readkey:=last;
end
else
begin
asm
movb $0,%ah
pushl %ebp
int $0x16
popl %ebp
movb %al,char1
movb %ah,char2
end;
if char1=#0 then
begin
is_last:=true;
last:=char2;
end;
readkey:=char1;
end;
end;
function keypressed : boolean;
begin
if is_last then
begin
keypressed:=true;
exit;
end
else
begin
asm
movb $1,%ah
pushl %ebp
int $0x16
popl %ebp
setnz %al
movb %al,__RESULT
end;
end;
end;
{*************************************************************************
Delay
*************************************************************************}
procedure Delayloop;assembler;
asm
.LDelayLoop1:
subl $1,%eax
jc .LDelayLoop2
cmpl %fs:(%edi),%ebx
je .LDelayLoop1
.LDelayLoop2:
end;
procedure initdelay;assembler;
asm
movl $0x46c,%edi
movl $-28,%edx
movl %fs:(%edi),%ebx
.LInitDel1:
cmpl %fs:(%edi),%ebx
je .LInitDel1
movl %fs:(%edi),%ebx
movl %edx,%eax
call DelayLoop
notl %eax
xorl %edx,%edx
movl $55,%ecx
divl %ecx
movl %eax,DelayCnt
end;
procedure Delay(MS: Word);assembler;
asm
movzwl MS,%ecx
jecxz .LDelay2
movl $0x400,%edi
movl DelayCnt,%edx
movl %fs:(%edi),%ebx
.LDelay1:
movl %edx,%eax
call DelayLoop
loop .LDelay1
.LDelay2:
end;
procedure sound(hz : word);
begin
if hz=0 then
begin
nosound;
exit;
end;
asm
movzwl hz,%ecx
movl $1193046,%eax
cltd
divl %ecx
movl %eax,%ecx
movb $0xb6,%al
outb %al,$0x43
movb %cl,%al
outb %al,$0x42
movb %ch,%al
outb %al,$0x42
inb $0x61,%al
orb $0x3,%al
outb %al,$0x61
end ['EAX','ECX','EDX'];
end;
procedure nosound;
begin
asm
inb $0x61,%al
andb $0xfc,%al
outb %al,$0x61
end ['EAX'];
end;
{****************************************************************************
HighLevel Crt Functions
****************************************************************************}
procedure removeline(y : longint);
var
fil : word;
begin
fil:=32 or (textattr shl 8);
y:=WinMinY+y-1;
While (y<WinMaxY) do
begin
dosmemmove($b800,(y*ScreenWidth+(WinMinX-1))*2,
$b800,((y-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1)*2);
inc(y);
end;
dosmemfillword($b800,((WinMaxY-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1),fil);
end;
procedure delline;
begin
removeline(wherey);
end;
procedure insline;
var
my,y : longint;
fil : word;
begin
fil:=32 or (textattr shl 8);
y:=WhereY;
my:=WinMaxY-WinMinY;
while (my>=y) do
begin
dosmemmove($b800,(((WinMinY+my-1)-1)*ScreenWidth+(WinMinX-1))*2,
$b800,(((WinMinY+my)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1)*2);
dec(my);
end;
dosmemfillword($b800,(((WinMinY+y-1)-1)*ScreenWidth+(WinMinX-1))*2,(WinMaxX-WinMinX+1),fil);
end;
{****************************************************************************
Extra Crt Functions
****************************************************************************}
procedure cursoron;
begin
asm
movb $1,%ah
movb $10,%cl
movb $9,%ch
pushl %ebp
int $0x10
popl %ebp
end;
end;
procedure cursoroff;
begin
asm
movb $1,%ah
movb $-1,%cl
movb $-1,%ch
pushl %ebp
int $0x10
popl %ebp
end;
end;
procedure cursorbig;
begin
asm
movb $1,%ah
movw $110,%cx
pushl %ebp
int $0x10
popl %ebp
end;
end;
{*****************************************************************************
Read and Write routines
*****************************************************************************}
var
CurrX,CurrY : longint;
Procedure WriteChar(c:char);
var
chattr : word;
begin
case c of
#10 : inc(CurrY);
#13 : CurrX:=WinMinX;
#8 : begin
if CurrX>WinMinX then
dec(CurrX);
end;
#7 : begin { beep }
end;
else
begin
chattr:=(textattr shl 8) or byte(c);
dosmemput($b800,((CurrY-1)*ScreenWidth+(CurrX-1))*2,chattr,2);
inc(CurrX);
end;
end;
if CurrX>WinMaxX then
begin
CurrX:=WinMinX;
inc(CurrY);
end;
while CurrY>WinMaxY do
begin
removeline(1);
dec(CurrY);
end;
end;
Function CrtWrite(var f : textrec):integer;
var
i : longint;
begin
GetScreenCursor(CurrX,CurrY);
for i:=0 to f.bufpos-1 do
WriteChar(f.buffer[i]);
SetScreenCursor(CurrX,CurrY);
f.bufpos:=0;
CrtWrite:=0;
end;
Function CrtRead(Var F: TextRec): Integer;
procedure BackSpace;
begin
if (f.bufpos>0) and (f.bufpos=f.bufend) then
begin
WriteChar(#8);
WriteChar(' ');
WriteChar(#8);
dec(f.bufpos);
dec(f.bufend);
end;
end;
var
ch : Char;
Begin
GetScreenCursor(CurrX,CurrY);
f.bufpos:=0;
f.bufend:=0;
repeat
if f.bufpos>f.bufend then
f.bufend:=f.bufpos;
SetScreenCursor(CurrX,CurrY);
ch:=readkey;
case ch of
#0 : case readkey of
#71 : while f.bufpos>0 do
begin
dec(f.bufpos);
WriteChar(#8);
end;
#75 : if f.bufpos>0 then
begin
dec(f.bufpos);
WriteChar(#8);
end;
#77 : if f.bufpos<f.bufend then
begin
WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos);
end;
#79 : while f.bufpos<f.bufend do
begin
WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos);
end;
end;
^S,
#8 : BackSpace;
^Y,
#27 : begin
f.bufpos:=f.bufend;
while f.bufend>0 do
BackSpace;
end;
#13 : begin
WriteChar(#13);
WriteChar(#10);
f.bufptr^[f.bufend]:=#13;
f.bufptr^[f.bufend+1]:=#10;
inc(f.bufend,2);
break;
end;
#26 : if CheckEOF then
begin
f.bufptr^[f.bufend]:=#26;
inc(f.bufend);
break;
end;
else
begin
if f.bufpos<f.bufsize-2 then
begin
f.buffer[f.bufpos]:=ch;
inc(f.bufpos);
WriteChar(ch);
end;
end;
end;
until false;
f.bufpos:=0;
SetScreenCursor(CurrX,CurrY);
CrtRead:=0;
End;
Function CrtReturn:Integer;
Begin
CrtReturn:=0;
end;
Function CrtClose(Var F: TextRec): Integer;
Begin
F.Mode:=fmClosed;
CrtClose:=0;
End;
Function CrtOpen(Var F: TextRec): Integer;
Begin
If F.Mode=fmOutput Then
begin
TextRec(F).InOutFunc:=@CrtWrite;
TextRec(F).FlushFunc:=@CrtWrite;
end
Else
begin
F.Mode:=fmInput;
TextRec(F).InOutFunc:=@CrtRead;
TextRec(F).FlushFunc:=@CrtReturn;
end;
TextRec(F).CloseFunc:=@CrtClose;
CrtOpen:=0;
End;
procedure AssignCrt(var F: Text);
begin
Assign(F,'');
TextRec(F).OpenFunc:=@CrtOpen;
end;
var
x,y : longint;
begin
{ Load startup values }
ScreenWidth:=GetScreenWidth;
ScreenHeight:=GetScreenHeight;
WindMax:=(ScreenWidth-1) or ((ScreenHeight-1) shl 8);
{ Load TextAttr }
GetScreenCursor(x,y);
dosmemget($b800,((y-1)*ScreenWidth+(x-1))*2+1,TextAttr,1);
dosmemget($40,$49,lastmode,1);
{ Redirect the standard output }
assigncrt(Output);
Rewrite(Output);
TextRec(Output).Handle:=StdOutputHandle;
assigncrt(Input);
Reset(Input);
TextRec(Input).Handle:=StdInputHandle;
{ Calculates delay calibration }
initdelay;
end.
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
+ removed logs
}

83
rtl/go32v1/disk.inc
View File

@ -1,83 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
Disk functions from Delphi's sysutils.pas
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.
**********************************************************************}
Function DiskFree (Drive : Byte) : Longint;
var
Regs: Registers;
begin
Regs.Dl := Drive;
Regs.Ah := $36;
intr($21, Regs);
if Regs.Ax <> $FFFF then
result := Regs.Ax * Regs.Bx * Regs.Cx
else
result := -1;
end;
Function DiskSize (Drive : Byte) : Longint;
var
Regs: Registers;
begin
Regs.Dl := Drive;
Regs.Ah := $36;
Intr($21, Regs);
if Regs.Ax <> $FFFF then
result := Regs.Ax * Regs.Cx * Regs.Dx
else
result := -1;
end;
Function GetCurrentDir : String;
begin
GetDir(0, result);
end;
Function SetCurrentDir (Const NewDir : String) : Boolean;
begin
{$I-}
ChDir(NewDir);
result := (IOResult = 0);
{$I+}
end;
Function CreateDir (Const NewDir : String) : Boolean;
begin
{$I-}
MkDir(NewDir);
result := (IOResult = 0);
{$I+}
end;
Function RemoveDir (Const Dir : String) : Boolean;
begin
{$I-}
RmDir(Dir);
result := (IOResult = 0);
{$I+}
end;
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
+ removed logs
}

713
rtl/go32v1/dos.pp
View File

@ -1,713 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team.
Dos unit for BP7 compatible RTL
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.
**********************************************************************}
unit dos;
interface
Uses
Go32;
Const
{Bitmasks for CPU Flags}
fcarry = $0001;
fparity = $0004;
fauxiliary = $0010;
fzero = $0040;
fsign = $0080;
foverflow = $0800;
{Bitmasks for file attribute}
readonly = $01;
hidden = $02;
sysfile = $04;
volumeid = $08;
directory = $10;
archive = $20;
anyfile = $3F;
{File Status}
fmclosed = $D7B0;
fminput = $D7B1;
fmoutput = $D7B2;
fminout = $D7B3;
Type
comstr = string[127]; { command line string }
pathstr = string[79]; { string for a file path }
dirstr = string[67]; { string for a directory }
namestr = string[8]; { string for a file name }
extstr = string[4]; { string for an extension }
{
filerec.inc contains the definition of the filerec.
textrec.inc contains the definition of the textrec.
It is in a separate file to make it available in other units without
having to use the DOS unit for it.
}
{$i filerec.inc}
{$i textrec.inc}
DateTime = packed record
Year,
Month,
Day,
Hour,
Min,
Sec : word;
End;
searchrec = packed record
fill : array[1..21] of byte;
attr : byte;
time : longint;
reserved : word; { requires the DOS extender (DJ GNU-C) }
size : longint;
name : string[15]; { the same size as declared by (DJ GNU C) }
end;
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
Var
DosError : integer;
{Interrupt}
Procedure Intr(intno: byte; var regs: registers);
Procedure MSDos(var regs: registers);
{Info/Date/Time}
Function DosVersion: Word;
Procedure GetDate(var year, month, mday, wday: word);
Procedure GetTime(var hour, minute, second, sec100: word);
procedure SetDate(year,month,day: word);
Procedure SetTime(hour,minute,second,sec100: word);
Procedure UnpackTime(p: longint; var t: datetime);
Procedure PackTime(var t: datetime; var p: longint);
{Exec}
Procedure Exec(const path: pathstr; const comline: comstr);
Function DosExitCode: word;
{Disk}
Function DiskFree(drive: byte) : longint;
Function DiskSize(drive: byte) : longint;
Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
Procedure FindNext(var f: searchRec);
Procedure FindClose(Var f: SearchRec);
{File}
Procedure GetFAttr(var f; var attr: word);
Procedure GetFTime(var f; var time: longint);
Function FSearch(path: pathstr; dirlist: string): pathstr;
Function FExpand(const path: pathstr): pathstr;
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
{Environment}
Function EnvCount: longint;
Function EnvStr(index: integer): string;
Function GetEnv(envvar: string): string;
{Misc}
Procedure SetFAttr(var f; attr: word);
Procedure SetFTime(var f; time: longint);
Procedure GetCBreak(var breakvalue: boolean);
Procedure SetCBreak(breakvalue: boolean);
Procedure GetVerify(var verify: boolean);
Procedure SetVerify(verify: boolean);
{Do Nothing Functions}
Procedure SwapVectors;
Procedure GetIntVec(intno: byte; var vector: pointer);
Procedure SetIntVec(intno: byte; vector: pointer);
Procedure Keep(exitcode: word);
implementation
uses
strings;
{$ASMMODE ATT}
{******************************************************************************
--- Dos Interrupt ---
******************************************************************************}
var
dosregs : registers;
procedure LoadDosError;
begin
if (dosregs.flags and carryflag) <> 0 then
{ conversion from word to integer !!
gave a Bound check error if ax is $FFFF !! PM }
doserror:=integer(dosregs.ax)
else
doserror:=0;
end;
{$ASMMODE DIRECT}
procedure intr(intno : byte;var regs : registers);
begin
asm
.data
int86:
.byte 0xcd
int86_vec:
.byte 0x03
jmp int86_retjmp
.text
movl 8(%ebp),%eax
movb %al,int86_vec
movl 10(%ebp),%eax
// do not use first int
addl $2,%eax
movl 4(%eax),%ebx
movl 8(%eax),%ecx
movl 12(%eax),%edx
movl 16(%eax),%ebp
movl 20(%eax),%esi
movl 24(%eax),%edi
movl (%eax),%eax
jmp int86
int86_retjmp:
pushf
pushl %ebp
pushl %eax
movl %esp,%ebp
// calc EBP new
addl $12,%ebp
movl 10(%ebp),%eax
// do not use first int
addl $2,%eax
popl (%eax)
movl %ebx,4(%eax)
movl %ecx,8(%eax)
movl %edx,12(%eax)
// restore EBP
popl %edx
movl %edx,16(%eax)
movl %esi,20(%eax)
movl %edi,24(%eax)
// ignore ES and DS
popl %ebx /* flags */
movl %ebx,32(%eax)
// FS and GS too
end;
end;
{$ASMMODE ATT}
procedure msdos(var regs : registers);
begin
intr($21,regs);
end;
{******************************************************************************
--- Info / Date / Time ---
******************************************************************************}
function dosversion : word;
begin
dosregs.ax:=$3000;
msdos(dosregs);
dosversion:=dosregs.ax;
end;
procedure getdate(var year,month,mday,wday : word);
begin
dosregs.ax:=$2a00;
msdos(dosregs);
wday:=dosregs.al;
year:=dosregs.cx;
month:=dosregs.dh;
mday:=dosregs.dl;
end;
procedure setdate(year,month,day : word);
begin
dosregs.cx:=year;
dosregs.dh:=month;
dosregs.dl:=day;
dosregs.ah:=$2b;
msdos(dosregs);
end;
procedure gettime(var hour,minute,second,sec100 : word);
begin
dosregs.ah:=$2c;
msdos(dosregs);
hour:=dosregs.ch;
minute:=dosregs.cl;
second:=dosregs.dh;
sec100:=dosregs.dl;
end;
procedure settime(hour,minute,second,sec100 : word);
begin
dosregs.ch:=hour;
dosregs.cl:=minute;
dosregs.dh:=second;
dosregs.dl:=sec100;
dosregs.ah:=$2d;
msdos(dosregs);
DosError:=0;
end;
Procedure packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin
sec:=(p and 31) shl 1;
min:=(p shr 5) and 63;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end;
End;
{******************************************************************************
--- Exec ---
******************************************************************************}
var
lastdosexitcode : word;
procedure exec(const path : pathstr;const comline : comstr);
var
i : longint;
b : array[0..255] of char;
begin
doserror:=0;
for i:=1to length(path) do
if path[i]='/' then
b[i-1]:='\'
else
b[i-1]:=path[i];
b[i]:=' ';
inc(i);
move(comline[1],b[i],length(comline));
inc(i,length(comline));
b[i]:=#0;
asm
leal b,%ebx
movw $0xff07,%ax
int $0x21
movw %ax,LastDosExitCode
end;
end;
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode;
end;
procedure getcbreak(var breakvalue : boolean);
begin
dosregs.ax:=$3300;
msdos(dosregs);
breakvalue:=dosregs.dl<>0;
end;
procedure setcbreak(breakvalue : boolean);
begin
dosregs.ax:=$3301;
dosregs.dl:=ord(breakvalue);
msdos(dosregs);
end;
procedure getverify(var verify : boolean);
begin
dosregs.ah:=$54;
msdos(dosregs);
verify:=dosregs.al<>0;
end;
procedure setverify(verify : boolean);
begin
dosregs.ah:=$2e;
dosregs.al:=ord(verify);
msdos(dosregs);
end;
{******************************************************************************
--- Disk ---
******************************************************************************}
function diskfree(drive : byte) : longint;
begin
dosregs.dl:=drive;
dosregs.ah:=$36;
msdos(dosregs);
if dosregs.ax<>$FFFF then
diskfree:=dosregs.ax*dosregs.bx*dosregs.cx
else
diskfree:=-1;
end;
function disksize(drive : byte) : longint;
begin
dosregs.dl:=drive;
dosregs.ah:=$36;
msdos(dosregs);
if dosregs.ax<>$FFFF then
disksize:=dosregs.ax*dosregs.cx*dosregs.dx
else
disksize:=-1;
end;
{******************************************************************************
--- DosFindfirst DosFindNext ---
******************************************************************************}
procedure dossearchrec2searchrec(var f : searchrec);
var
len : longint;
begin
len:=StrLen(@f.Name);
Move(f.Name[0],f.Name[1],Len);
f.Name[0]:=chr(len);
end;
procedure Dosfindfirst(path : pchar;attr : word;var f : searchrec);
var
i : longint;
begin
{ allow slash as backslash }
for i:=0 to strlen(path) do
if path[i]='/' then path[i]:='\';
asm
movl f,%edx
movb $0x1a,%ah
int $0x21
movl path,%edx
movzwl attr,%ecx
movb $0x4e,%ah
int $0x21
jnc .LFF
movw %ax,DosError
.LFF:
end;
dossearchrec2searchrec(f);
end;
procedure Dosfindnext(var f : searchrec);
begin
asm
movl 12(%ebp),%edx
movb $0x1a,%ah
int $0x21
movb $0x4f,%ah
int $0x21
jnc .LFN
movw %ax,DosError
.LFN:
end;
dossearchrec2searchrec(f);
end;
{******************************************************************************
--- Findfirst FindNext ---
******************************************************************************}
procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
var
path0 : array[0..256] of char;
begin
doserror:=0;
strpcopy(path0,path);
Dosfindfirst(path0,attr,f);
end;
procedure findnext(var f : searchRec);
begin
doserror:=0;
Dosfindnext(f);
end;
Procedure FindClose(Var f: SearchRec);
begin
DosError:=0;
end;
procedure swapvectors;
begin
DosError:=0;
end;
{******************************************************************************
--- File ---
******************************************************************************}
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
p1,i : longint;
begin
{ allow slash as backslash }
for i:=1 to length(path) do
if path[i]='/' then path[i]:='\';
{ get drive name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=path[1]+':';
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('\',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
begin
p1:=pos('.',path);
if p1>0 then
begin
ext:=copy(path,p1,4);
delete(path,p1,length(path)-p1+1);
end
else
ext:='';
name:=path;
end;
end;
(*
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_DRIVES}
{$UNDEF FPC_FEXPAND_UNC}
Function FSearch(path: pathstr; dirlist: string): pathstr;
var
i,p1 : longint;
s : searchrec;
newdir : pathstr;
begin
{ No wildcards allowed in these things }
if (pos('?',path)<>0) or (pos('*',path)<>0) then
fsearch:=''
else
begin
{ allow slash as backslash }
for i:=1 to length(dirlist) do
if dirlist[i]='/' then dirlist[i]:='\';
repeat
p1:=pos(';',dirlist);
if p1<>0 then
begin
newdir:=copy(dirlist,1,p1-1);
delete(dirlist,1,p1);
end
else
begin
newdir:=dirlist;
dirlist:='';
end;
if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
newdir:=newdir+'\';
findfirst(newdir+path,anyfile,s);
if doserror=0 then
newdir:=newdir+path
else
newdir:='';
until (dirlist='') or (newdir<>'');
fsearch:=newdir;
end;
end;
{******************************************************************************
--- Get/Set File Time,Attr ---
******************************************************************************}
procedure getftime(var f;var time : longint);
begin
dosregs.bx:=textrec(f).handle;
dosregs.ax:=$5700;
msdos(dosregs);
loaddoserror;
time:=(dosregs.dx shl 16)+dosregs.cx;
end;
procedure setftime(var f;time : longint);
begin
dosregs.bx:=textrec(f).handle;
dosregs.cx:=time and $ffff;
dosregs.dx:=time shr 16;
dosregs.ax:=$5701;
msdos(dosregs);
loaddoserror;
end;
procedure getfattr(var f;var attr : word);
begin
dosregs.edx:=longint(@filerec(f).name);
dosregs.ax:=$4300;
msdos(dosregs);
LoadDosError;
Attr:=dosregs.cx;
end;
procedure setfattr(var f;attr : word);
begin
dosregs.edx:=longint(@filerec(f).name);
dosregs.ax:=$4301;
dosregs.cx:=attr;
msdos(dosregs);
LoadDosError;
end;
{******************************************************************************
--- Environment ---
******************************************************************************}
function envcount : longint;
var
hp : ppchar;
begin
hp:=envp;
envcount:=0;
while assigned(hp^) do
begin
inc(envcount);
hp:=hp+4;
end;
end;
function envstr(index : integer) : string;
begin
if (index<=0) or (index>envcount) then
begin
envstr:='';
exit;
end;
envstr:=strpas(ppchar(envp+4*(index-1))^);
end;
Function GetEnv(envvar: string): string;
var
hp : ppchar;
hs : string;
eqpos : longint;
begin
envvar:=upcase(envvar);
hp:=envp;
getenv:='';
while assigned(hp^) do
begin
hs:=strpas(hp^);
eqpos:=pos('=',hs);
if copy(hs,1,eqpos-1)=envvar then
begin
getenv:=copy(hs,eqpos+1,255);
exit;
end;
hp:=hp+4;
end;
end;
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
End;
end.
{
$Log$
Revision 1.4 2001-11-23 00:27:22 carl
* updated behavior of some routines to conform to docs
Revision 1.3 2001/03/10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed
Revision 1.2 2000/07/13 11:33:38 michael
+ removed logs
}

173
rtl/go32v1/filutil.inc
View File

@ -1,173 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
File utility calls
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.
**********************************************************************}
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
Begin
//!! Needs implementing
end;
Function FileCreate (Const FileName : String) : Longint;
begin
//!! Needs implementing
end;
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
begin
//!! Needs implementing
end;
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
begin
//!! Needs implementing
end;
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
begin
//!! Needs implementing
end;
Procedure FileClose (Handle : Longint);
begin
//!! Needs implementing
end;
Function FileAge (Const FileName : String): Longint;
begin
//!! Needs implementing
end;
Function FileExists (Const FileName : String) : Boolean;
begin
//!! Needs implementing
end;
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
begin
//!! Needs implementing
end;
Function FindNext (Var Rslt : TSearchRec) : Longint;
begin
//!! Needs implementing
end;
Procedure FindClose (Var F : TSearchrec);
begin
//!! Needs implementing
end;
Function FileTruncate (Handle,Size: Longint) : boolean;
begin
//!! Needs implementing
end;
Function FileGetDate (Handle : Longint) : Longint;
begin
//!! Needs implementing
end;
Function FileSetDate (Handle,Age : Longint) : Longint;
begin
//!! Needs implementing
end;
Function FileGetAttr (Const FileName : String) : Longint;
begin
//!! Needs implementing
end;
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
begin
//!! Needs implementing
end;
Function DeleteFile (Const FileName : String) : Boolean;
begin
//!! Needs implementing
end;
Function RenameFile (Const OldName, NewName : String) : Boolean;
begin
//!! Needs implementing
end;
Function FileSearch (Const Name, DirList : String) : String;
begin
//!! Needs implementing
end;
Procedure GetLocalTime(var SystemTime: TSystemTime);
begin
end ;
{ ---------------------------------------------------------------------
Internationalization settings
---------------------------------------------------------------------}
procedure InitAnsi;
begin
end;
Procedure InitInternational;
begin
end;
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
+ removed logs
}

1217
rtl/go32v1/go32.pp
View File

File diff suppressed because it is too large Load Diff

396
rtl/go32v1/msmouse.pp
View File

@ -1,396 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by 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.
**********************************************************************
}
Unit MSMouse;
Interface
{
Mouse support functions and procedures, with error checking: if mouse
isn't present then the routine ends. If you want to remove error checking,
remove the next define.
}
{$DEFINE MOUSECHECK}
{initializes the mouse with the default values for the current screen mode}
Function InitMouse:Boolean;
{shows mouse pointer,text+graphics screen support}
Procedure ShowMouse;
{hides mouse pointer}
Procedure HideMouse;
{reads mouse position in pixels (divide by 8 to get text position in standard
text mode) and reads the buttons state:
bit 1 set -> left button pressed
bit 2 set -> right button pressed
bit 3 set -> middle button pressed
Have a look at the example program in the manual to see how you can use this}
Procedure GetMouseState(var x,y, buttons :Longint);
{returns true if the left button is pressed}
Function LPressed:Boolean;
{returns true if the right button is pressed}
Function RPressed:Boolean;
{returns true if the middle button is pressed}
Function MPressed:Boolean;
{positions the mouse pointer}
Procedure SetMousePos(x,y:Longint);
{returns at which position "button" was last pressed in x,y and returns the
number of times this button has been pressed since the last time this
function was called with "button" as parameter. For button you can use the
LButton, RButton and MButton constants for resp. the left, right and middle
button}
Function GetLastButtonPress(button:Longint;var x,y:Longint): Longint;
{returns at which position "button" was last released in x,y and returns the
number of times this button has been re since the last time. For button
you can use the LButton, RButton and MButton constants for resp. the left,
right and middle button}
Function GetLastButtonRelease (button : Longint; var x,y:Longint): Longint;
{sets mouse's x range, with Min and Max resp. the higest and the lowest
column (in pixels) in between which the mouse cursor can move}
Procedure SetMouseXRange (Min,Max:Longint);
{sets mouse's y range, with Min and Max resp. the higest and the lowest
row (in pixels) in between which the mouse cursor can move}
Procedure SetMouseYRange (Min,Max:Longint);
{set the window coordinates in which the mouse cursor can move}
Procedure SetMouseWindow(x1,y1,x2,y2:Longint);
{sets the mouse shape in text mode: background and foreground color and the
Ascii value with which the character on screen is XOR'ed when the cursor
moves over it. Set to 0 for a "transparent" cursor}
Procedure SetMouseShape(ForeColor,BackColor,Ascii:Byte);
{sets the mouse ascii in text mode. The difference between this one and
SetMouseShape, is that the foreground and background colors stay the same
and that the Ascii code you enter is the character that you will get on
screen; there's no XOR'ing}
Procedure SetMouseAscii(Ascii:Byte);
{set mouse speed in mickey's/pixel; default: horizontal: 8; vertical: 16}
Procedure SetMouseSpeed(Horizontal ,Vertical:Longint);
{set a rectangle on screen that mouse will disappear if it is moved into}
Procedure SetMouseHideWindow(x1,y1,x2,y2:Longint);
Const LButton = 1; {left button}
RButton = 2; {right button}
MButton = 4; {middle button}
Var
MouseFound: Boolean;
Implementation
{$asmmode ATT}
Function InitMouse: Boolean;
begin
asm
xorl %eax,%eax
pushl %ebp
int $0x33
popl %ebp
cmpw $0xffff,%ax
setz %al
movb %al,__RESULT
end;
end;
Procedure ShowMouse;
begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $1,%eax
pushl %ebp
int $0x33
popl %ebp
end;
end;
Procedure HideMouse;
begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $2,%eax
pushl %ebp
int $0x33
popl %ebp
end;
end;
Procedure GetMouseState(var x,y,buttons:Longint);
begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $3,%eax
pushl %ebp
int $0x33
popl %ebp
andl $0xffff,%ecx
andl $0xffff,%edx
movl x,%eax
movl %ecx,(%eax)
movl y,%eax
movl %edx,(%eax)
movl buttons,%eax
movw %bx,(%eax)
end;
end;
Function LPressed:Boolean;
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $3,%eax
pushl %ebp
int $0x33
popl %ebp
movl %ebx,%eax
andl $1,%eax
movb %al,__RESULT
end;
end;
Function RPressed:Boolean;
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $3,%eax
pushl %ebp
int $0x33
popl %ebp
movl %ebx,%eax
shrl $1,%eax
andl $1,%eax
movb %al,__RESULT
end;
end;
Function MPressed:Boolean;
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $3,%eax
pushl %ebp
int $0x33
popl %ebp
movl %ebx,%eax
shrl $2,%eax
andl $1,%eax
movb %al,__RESULT
end;
end;
Procedure SetMousePos(x,y:Longint);
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $4,%eax
movl x,%ecx
movl y,%edx
pushl %ebp
int $0x33
popl %ebp
End;
End;
Function GetLastButtonPress(Button: Longint;var x,y:Longint):Longint;
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $5,%eax
movl button,%ebx
shrl $1, %ebx {0 = left, 1 = right, 2 = middle}
pushl %ebp
int $0x33
popl %ebp
andl $0xffff,%ebx
andl $0xffff,%edx
andl $0xffff,%ecx
movl %ebx, __RESULT
movl x,%eax
movl %ecx,(%eax)
movl y,%eax
movl %edx,(%eax)
end;
end;
Function GetLastButtonRelease (button : Longint; var x,y:Longint): Longint;
begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $6,%eax
movl button,%ebx
shrl $1, %ebx {0 = left, 1 = right, 2 = middle}
pushl %ebp
int $0x33
popl %ebp
andl $0xffff,%ebx
andl $0xffff,%ecx
andl $0xffff,%edx
movl %ebx,__RESULT
movl x,%eax
movl %ecx,(%eax)
movl y,%eax
movl %edx,(%eax)
end;
end;
Procedure SetMouseXRange (Min,Max:Longint);
begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $7,%eax
movl min,%ecx
movl max,%edx
pushl %ebp
int $0x33
popl %ebp
end;
end;
Procedure SetMouseYRange (min,max:Longint);
begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $8,%eax
movl min,%ecx
movl max,%edx
pushl %ebp
int $0x33
popl %ebp
end;
end;
Procedure SetMouseWindow(x1,y1,x2,y2:Longint);
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
SetMouseXRange(x1,x2);
SetMouseYRange(y1,y2);
End;
Procedure SetMouseShape(ForeColor,BackColor,Ascii:Byte);
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
xorl %ebx,%ebx
movl $0xa,%eax
movl $0xffff,%ecx
xorl %edx,%edx
movb BackColor,%dh
shlb $4,%dh
addb ForeColor,%dh
movb Ascii,%dl
pushl %ebp
int $0x33
popl %ebp
End;
End;
Procedure SetMouseAscii(Ascii:byte);
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
xorl %ebx,%ebx
movl $0xa,%eax
movl $0xff00,%ecx
xorl %edx,%edx
movb Ascii,%dl
pushl %ebp
int $0x33
popl %ebp
End;
End;
Procedure SetMouseHideWindow(x1,y1,x2,y2:Longint);
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $0x0010,%eax
movl x1,%ecx
movl y1,%edx
movl x2,%esi
movl y2,%edi
pushl %ebp
int $0x33
popl %ebp
end;
End;
Procedure SetMouseSpeed(Horizontal,Vertical:Longint);
Begin
{$IFDEF MOUSECHECK}
If (Not MouseFound) Then Exit;
{$ENDIF}
asm
movl $0x0f,%eax
movl Horizontal,%ecx
movl Vertical,%edx
pushl %ebp
int $0x33
popl %ebp
end;
End;
Begin
MouseFound := InitMouse;
End.
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
+ removed logs
}

179
rtl/go32v1/objinc.inc
View File

@ -1,179 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team.
Includefile for objects.pp implementing OS-dependent file routines
for Go32V1
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.
**********************************************************************
}
{---------------------------------------------------------------------------}
{ FileClose -> Platforms DOS - Not checked }
{---------------------------------------------------------------------------}
FUNCTION FileClose(Handle: THandle): word;
begin
asm
xor %bx,%bx
movw handle,%bx
movb $0x3e,%ah
pushl %ebp
int $0x21
popl %ebp
end;
FileClose := 0;
end;
{---------------------------------------------------------------------------}
{ FileOpen -> Platforms DOS - Checked 05May1998 CEC }
{ Returns 0 on failure }
{---------------------------------------------------------------------------}
FUNCTION FileOpen (Var FileName: AsciiZ; Mode: Word): THandle;
var
AMode: word;
begin
if Mode=stCreate then
Begin
AMode:=$8302;
end
else
Begin
Case (Mode and 3) of
0 : AMode:=$8001;
1 : AMode:=$8404;
2 : AMode:=$8404;
end;
end;
asm
xorl %eax, %eax
movw %ax, DosStreamError
movl FileName, %ebx
movw $0xff02, %ax
movw AMode, %cx
pushl %ebp
int $0x21
popl %ebp
jnc .Lexit1
movw %ax, DosStreamError { Hold Error }
xorl %eax, %eax { Open Failed }
.Lexit1:
movw %ax, __RESULT
END;
end;
{***************************************************************************}
{ DosSetFilePtr -> Platforms DOS - Checked 05May1998 CEC }
{***************************************************************************}
FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word;
Var Actual: LongInt): Word;
Var
val : longint;
BEGIN
asm
movw MoveType, %ax; { Load move type }
movb $0x42, %ah;
movl pos, %edx; { Load file position }
andl $0xffff,%edx { Only keep low word }
movl pos, %ecx
shrl $16,%ecx;
movw Handle, %bx; { Load file handle }
pushl %ebp;
int $0x21; { Position the file }
popl %ebp;
jc .Lexit4
shll $16,%edx
movzwl %ax,%eax
orl %edx,%eax
movl %eax,val { Update new position }
xorl %eax, %eax;
.Lexit4:
movw %ax, DosStreamError { DOS error returned }
.Lend:
END;
Actual := val;
SetFilePos := DosStreamError; { Return any error }
END;
{---------------------------------------------------------------------------}
{ FileRead -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileRead (Handle: THandle; Var Buf; Count: Sw_Word;
Var Actual: Sw_Word): Word;
BEGIN
asm
movl count,%ecx
movl buf,%edx
xorl %ebx,%ebx
movw handle,%bx
movb $0x3f,%ah
int $0x21
jnc .LDOSREAD1
movw %ax,DosStreamError
xorl %eax,%eax
.LDOSREAD1:
end;
Actual:=Count;
FileRead:=DosStreamError;
end;
{---------------------------------------------------------------------------}
{ FileWrite -> Platforms DOS - Checked 05May1998 CEC }
{---------------------------------------------------------------------------}
FUNCTION FileWrite (Handle: THandle; Var Buf; Count: Sw_Word; Var Actual: Sw_Word): Word;
BEGIN
Actual:=0;
asm
movl Count,%ecx
movl buf,%edx
xorl %ebx,%ebx
movw Handle,%bx
movb $0x40,%ah
pushl %ebp
int $0x21
pop %ebp
jnc .LDOSWRITE1
movw %ax,DosStreamError
.LDOSWRITE1:
end;
Actual:=Count;
FileWrite:=DosStreamError;
end;
{---------------------------------------------------------------------------}
{ SetFileSize -> Platforms DOS - Not Checked }
{---------------------------------------------------------------------------}
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
VAR Actual, Buf: LongInt;
BEGIN
SetFilePos(Handle,FileSize,0,Actual);
If (Actual = FileSize) Then
Begin
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
If (Actual <> -1) Then
SetFileSize := 0
Else
SetFileSize := 103; { File truncate error }
End
Else
SetFileSize := 103; { File truncate error }
END;
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
+ removed logs
}

46
rtl/go32v1/printer.pp
View File

@ -1,46 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl
member of the Free Pascal development team
Printer unit for BP7 compatible RTL
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.
**********************************************************************}
unit printer;
interface
var
lst : text;
implementation
var
old_exit : pointer;
procedure printer_exit;
begin
close(lst);
exitproc:=old_exit;
end;
begin
assign(lst,'PRN');
rewrite(lst);
old_exit:=exitproc;
exitproc:=@printer_exit;
end.
{
$Log$
Revision 1.2 2000-07-13 11:33:38 michael
+ removed logs
}

200
rtl/go32v1/prt0.as
View File

@ -1,200 +0,0 @@
#
# $Id$
# This file is part of the Free Pascal run time library.
# Copyright (c) 1999-2000 by the Free Pascal development team.
#
# Go32V1 Startup code
#
# 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.
#
# **********************************************************************
#
# Called as start(argc, argv, envp)
#
# gs:edx points to prog_info structure. All other registers are OBSOLETE
# but included for backwards compatibility
#
.text
.globl _start
_start:
.globl start
start:
# the first instruction must be movl %eax,
# because that is the way GO32V2 makes the difference between V1 and V2 coff format
movl %eax,__hard_master
movl %esi,___pid
movl %edi,___transfer_buffer
movl %ebx,_ScreenPrimary
movl %ebp,_ScreenSecondary
cmpl $0, %edx
je Lcopy_none
movw %gs,%cx
movw %ds,%ax
cmpw %cx,%ax
je Lcopy_none
# set the right size
movl $40,U_SYSTEM_GO32_INFO_BLOCK
movl %gs:(%edx), %ecx
cmpl U_SYSTEM_GO32_INFO_BLOCK, %ecx
jbe Lcopy_less
movl U_SYSTEM_GO32_INFO_BLOCK, %ecx
Lcopy_less:
movl $U_SYSTEM_GO32_INFO_BLOCK, %edi
addl $3, %ecx
andl $0xfffffffc, %ecx
movl %ecx, (%edi)
addl $4, %edi
addl $4, %edx
subl $4, %ecx
Lcopy_more:
movl %gs:(%edx), %eax
movl %eax, (%edi)
addl $4, %edx
addl $4, %edi
subl $4, %ecx
jnz Lcopy_more
movl U_SYSTEM_GO32_INFO_BLOCK+4, %eax
movl %eax, _ScreenPrimary
movl U_SYSTEM_GO32_INFO_BLOCK+8, %eax
movl %eax, _ScreenSecondary
movl U_SYSTEM_GO32_INFO_BLOCK+12, %eax
movl %eax, ___transfer_buffer
movl U_SYSTEM_GO32_INFO_BLOCK+20, %eax
movl %eax, ___pid
movl U_SYSTEM_GO32_INFO_BLOCK+24, %eax
movl %eax, __hard_master
jmp Lcopy_done
Lcopy_none:
movl %ebx,U_SYSTEM_GO32_INFO_BLOCK+4
movl %ebp,U_SYSTEM_GO32_INFO_BLOCK+8
movl %edi,U_SYSTEM_GO32_INFO_BLOCK+12
movl $4096,U_SYSTEM_GO32_INFO_BLOCK+16
movl %esi,U_SYSTEM_GO32_INFO_BLOCK+20
movl %eax,U_SYSTEM_GO32_INFO_BLOCK+24
movl $28, U_SYSTEM_GO32_INFO_BLOCK
Lcopy_done:
movw U_SYSTEM_GO32_INFO_BLOCK+36,%ax
movw %ax,_run_mode
# I need a value for the stack bottom,
# According to Pierre, from the source code of go32v1
# the stack is 256Kb in length
movl %esp,%eax
subl $0x40000,%eax
movl %eax,__stkbottom
movw U_SYSTEM_GO32_INFO_BLOCK+26,%ax
movw %ax,_core_selector
movl U_SYSTEM_GO32_INFO_BLOCK+28,%eax
movl %eax,U_SYSTEM_STUB_INFO
xorl %esi,%esi
xorl %edi,%edi
xorl %ebp,%ebp
xorl %ebx,%ebx
movl %esp,%ebx
movl $0x0,%ebp
movl %esp,%ebx
movl 8(%ebx),%eax
movl %eax,_environ
movl %eax,U_SYSTEM_ENVP
movl 4(%ebx),%eax
movl %eax,_args
movl %eax,U_SYSTEM_ARGV
movl (%ebx),%eax
movl %eax,_argc
movl %eax,U_SYSTEM_ARGC
call PASCALMAIN
exit_again:
movl $0x4c00,%eax
int $0x21
jmp exit_again
ret
.data
.globl _argc
_argc:
.long 0
.globl _args
_args:
.long 0
.globl _environ
_environ:
.long 0
.globl __stkbottom
__stkbottom:
.long 0
.globl _run_mode
_run_mode:
.word 0
.globl _core_selector
_core_selector:
.word 0
.globl ___pid
___pid:
.long 42
.globl ___transfer_buffer
___transfer_buffer:
.long 0
.globl _ScreenPrimary
_ScreenPrimary:
.long 0
.globl _ScreenSecondary
_ScreenSecondary:
.long 0
.globl __hard_master
__hard_master:
.byte 0
.globl __hard_slave
__hard_slave:
.byte 0
.globl __core_select
__core_select:
.short 0
#
# $Log$
# Revision 1.1 2000-07-13 06:30:34 michael
# + Initial import
#
# Revision 1.3 2000/01/07 16:41:30 daniel
# * copyright 2000
#
# Revision 1.2 2000/01/07 16:32:23 daniel
# * copyright 2000 added
#
# Revision 1.1 1998/12/21 13:07:02 peter
# * use -FE
#
# Revision 1.4 1998/08/04 13:35:34 carl
# * stack size default is 256Kb! not 16K! as information stated by Pierre
#
# Revision 1.3 1998/05/22 00:39:32 peter
# * go32v1, go32v2 recompiles with the new objects
# * remake3 works again with go32v2
# - removed some "optimizes" from daniel which were wrong
#
#

662
rtl/go32v1/system.pp
View File

@ -1,662 +0,0 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 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.
**********************************************************************}
unit system;
interface
{ include system-independent routine headers }
{$I systemh.inc}
{ include heap support headers }
{$I heaph.inc}
{Platform specific information}
const
LineEnding = #13#10;
{ LFNSupport is a variable here, defined below!!! }
DirectorySeparator = '\';
DriveSeparator = ':';
PathSeparator = ';';
FileNameCaseSensitive = false;
const
{ Default filehandles }
UnusedHandle = $ffff;
StdInputHandle = 0;
StdOutputHandle = 1;
StdErrorHandle = 2;
{ Default memory segments (Tp7 compatibility) }
seg0040 = $0040;
segA000 = $A000;
segB000 = $B000;
segB800 = $B800;
var
{ C-compatible arguments and environment }
argc : longint;
argv : ppchar;
envp : ppchar;
type
{ Dos Extender info }
p_stub_info = ^t_stub_info;
t_stub_info = packed 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;
t_go32_info_block = packed 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;
var
stub_info : p_stub_info;
go32_info_block : t_go32_info_block;
LFNSupport : boolean;
{ Needed for CRT unit }
function do_read(h,addr,len : longint) : longint;
implementation
{ include system independent routines }
{$I system.inc}
{$ASMMODE DIRECT}
procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_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 !!
With a 2048 byte safe area used to write to StdIo without crossing
the stack boundary
}
asm
pushl %eax
pushl %ebx
movl stack_size,%ebx
addl $2048,%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'];
HandleError(202);
end;
function paramcount : longint;
begin
paramcount := argc - 1;
end;
function paramstr(l : longint) : string;
begin
if (l>=0) and (l+1<=argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
procedure randomize;
Begin
asm
movb $0x2c,%ah
int $0x21
shll $16,%ecx
movw %dx,%cx
movl %ecx,randseed
end;
end;
{*****************************************************************************
Heap Management
*****************************************************************************}
function getheapstart:pointer;assembler;
asm
leal HEAP,%eax
end ['EAX'];
function getheapsize:longint;assembler;
asm
movl HEAPSIZE,%eax
end ['EAX'];
function Sbrk(size : longint) : longint;assembler;
asm
movl size,%ebx
movl $0x4a01,%eax
int $0x21
end;
{ include standard heap management }
{$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);assembler;
asm
movl h,%ebx
movb $0x3e,%ah
pushl %ebp
int $0x21
popl %ebp
jnc .LCLOSE1
movw %ax,inoutres
.LCLOSE1:
end;
procedure do_erase(p : pchar);
begin
AllowSlash(p);
asm
movl p,%edx
movb $0x41,%ah
pushl %ebp
int $0x21
popl %ebp
jnc .LERASE1
movw %ax,inoutres
.LERASE1:
end;
end;
procedure do_rename(p1,p2 : pchar);
begin
AllowSlash(p1);
AllowSlash(p2);
asm
movl p1,%edx
movl p2,%edi
movb $0x56,%ah
pushl %ebp
int $0x21
popl %ebp
jnc .LRENAME1
movw %ax,inoutres
.LRENAME1:
end;
end;
function do_write(h,addr,len : longint) : longint;assembler;
asm
movl len,%ecx
movl addr,%edx
movl h,%ebx
movb $0x40,%ah
int $0x21
jnc .LDOSWRITE1
movw %ax,inoutres
xorl %eax,%eax
.LDOSWRITE1:
end;
function do_read(h,addr,len : longint) : longint;assembler;
asm
movl len,%ecx
movl addr,%edx
movl h,%ebx
movb $0x3f,%ah
int $0x21
jnc .LDOSREAD1
movw %ax,inoutres
xorl %eax,%eax
.LDOSREAD1:
end;
function do_filepos(handle : longint) : longint;assembler;
asm
movl $0x4201,%eax
movl handle,%ebx
xorl %ecx,%ecx
xorl %edx,%edx
pushl %ebp
int $0x21
popl %ebp
jnc .LDOSFILEPOS1
movw %ax,inoutres
xorl %eax,%eax
jmp .LDOSFILEPOS2
.LDOSFILEPOS1:
shll $16,%edx
movzwl %ax,%eax
orl %edx,%eax
.LDOSFILEPOS2:
end;
procedure do_seek(handle,pos : longint);assembler;
asm
movl $0x4200,%eax
movl handle,%ebx
movl pos,%edx
movl %edx,%ecx
shrl $16,%ecx
pushl %ebp
int $0x21
popl %ebp
jnc .LDOSSEEK1
movw %ax,inoutres
.LDOSSEEK1:
end;
function do_seekend(handle : longint) : longint;assembler;
asm
movl $0x4202,%eax
movl handle,%ebx
xorl %ecx,%ecx
xorl %edx,%edx
pushl %ebp
int $0x21
popl %ebp
jnc .Lset_at_end1
movw %ax,inoutres
xorl %eax,%eax
jmp .Lset_at_end2
.Lset_at_end1:
shll $16,%edx
movzwl %ax,%eax
orl %edx,%eax
.Lset_at_end2:
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);assembler;
asm
movl $0x4200,%eax
movl handle,%ebx
movl pos,%edx
movl %edx,%ecx
shrl $16,%ecx
pushl %ebp
int $0x21
popl %ebp
jc .LTruncate1
movl handle,%ebx
movl %ebp,%edx
xorl %ecx,%ecx
movb $0x40,%ah
int $0x21
jnc .LTruncate2
.LTruncate1:
movw %ax,inoutres
.LTruncate2:
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 $100) the file will be append
when (flags and $1000) the file will be truncate/rewritten
when (flags and $10000) there is no check for close (needed for textfiles)
}
var
oflags : longint;
begin
AllowSlash(p);
{ close first if opened }
if ((flags and $10000)=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 $1000)<>0 then
begin
filerec(f).mode:=fmoutput;
oflags:=$8302;
end
else
if (flags and $100)<>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;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
asm
movl $0xff02,%eax
movl oflags,%ecx
movl p,%ebx
int $0x21
jnc .LOPEN1
movw %ax,inoutres
movw $0xffff,%ax
.LOPEN1:
movl f,%edx
movw %ax,(%edx)
end;
if (flags and $100)<>0 then
do_seekend(filerec(f).handle);
end;
function do_isdevice(handle : longint):boolean;assembler;
asm
movl $0x4400,%eax
movl handle,%ebx
pushl %ebp
int $0x21
popl %ebp
jnc .LDOSDEVICE
movw %ax,inoutres
xorl %edx,%edx
.LDOSDEVICE:
movl %edx,%eax
shrl $7,%eax
andl $1,%eax
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 func,%ah
int $0x21
jnc .LDOS_DIRS1
movw %ax,inoutres
.LDOS_DIRS1:
end;
end;
procedure mkdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($39,s);
end;
procedure rmdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($3a,s);
end;
procedure chdir(const s : string);[IOCheck];
begin
If InOutRes <> 0 then exit;
DosDir($3b,s);
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
var
temp : array[0..255] of char;
sof : pchar;
i : byte;
Err: boolean;
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
movw $0x4700,%ax
movb %al,Err
int $0x21
jnc .LGetDir
movw %ax, InOutRes
incb Err
.LGetDir:
end;
if Err and (DriveNr <> 0) then
begin
Dir := char (DriveNr + 64) + ':\';
Exit;
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 }
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;
dir:=upcase(dir);
end;
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
Procedure system_exit;
var
err : byte;
begin
flush(stderr);
err:=exitcode and $ff;
asm
movl $0x4c00,%eax
movb err,%al
int $0x21
end;
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
Begin
{$ifdef SYSTEMDEBUG}
{ to test stack depth }
loweststack:=maxlongint;
{$endif}
{ Setup heap }
InitHeap;
{ Setup stdin, stdout and stderr }
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ Reset IO Error }
InOutRes:=0;
End.
{
$Log$
Revision 1.8 2001-07-29 13:50:44 peter
* merged updates from v10
Revision 1.7 2001/06/30 18:55:49 hajny
* GetDir fix for inaccessible drives
Revision 1.6 2001/06/19 20:46:07 hajny
* platform specific constants moved after systemh.inc, BeOS omission corrected
Revision 1.5 2001/06/13 22:22:59 hajny
+ platform specific information
Revision 1.4 2001/03/21 21:08:20 hajny
* GetDir fixed
Revision 1.3 2001/03/10 09:57:51 hajny
* FExpand without IOResult change, remaining direct asm removed
Revision 1.2 2000/07/13 11:33:38 michael
+ removed logs
}