paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 13:29:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

* objects compiles for linux

Browse Source 
+ assign(pchar), assign(char), rename(pchar), rename(char)
  * fixed read_text_as_array
  + read_text_as_pchar which was not yet in the rtl
This commit is contained in:
peter 1998-05-21 19:30:46 +00:00
parent 4496a78375
commit eb39182b3b
13 changed files with 1042 additions and 1111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

421
rtl/dos/crt.pp
View File

@ -12,128 +12,108 @@
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************} **********************************************************************}
{
history:
29th may 1994: version 1.0
unit is completed
14th june 1994: version 1.01
the address from which startaddr was read wasn't right; fixed
18th august 1994: version 1.1
the upper left corner of winmin is now 0,0
19th september 1994: version 1.11
keypressed handles extended keycodes false; fixed
27th february 1995: version 1.12
* crtinoutfunc didn't the line wrap in the right way;
fixed
20th january 1996: version 1.13
- unused variables removed
21th august 1996: version 1.14
* adapted to newer FPKPascal versions
* make the comments english
6th november 1996: version 1.49
* some stuff for DPMI adapted
15th november 1996: version 1.5
* bug in screenrows fixed
13th november 1997: removed textrec definition, is now included from
textrec.inc
}
unit crt; unit crt;
interface
{$I os.inc} {$I os.inc}
interface
uses
go32;
const const
{ screen modes } { CRT modes }
bw40 = 0; BW40 = 0; { 40x25 B/W on Color Adapter }
co40 = 1; CO40 = 1; { 40x25 Color on Color Adapter }
bw80 = 2; BW80 = 2; { 80x25 B/W on Color Adapter }
co80 = 3; CO80 = 3; { 80x25 Color on Color Adapter }
mono = 7; Mono = 7; { 80x25 on Monochrome Adapter }
font8x8 = 256; Font8x8 = 256; { Add-in for ROM font }
{ screen color, fore- and background } { Mode constants for 3.0 compatibility }
black = 0; C40 = CO40;
blue = 1; C80 = CO80;
green = 2;
cyan = 3;
red = 4;
magenta = 5;
brown = 6;
lightgray = 7;
{ only foreground } { Foreground and background color constants }
darkgray = 8; Black = 0;
lightblue = 9; Blue = 1;
lightgreen = 10; Green = 2;
lightcyan = 11; Cyan = 3;
lightred = 12; Red = 4;
lightmagenta = 13; Magenta = 5;
yellow = 14; Brown = 6;
white = 15; LightGray = 7;
{ blink flag } { Foreground color constants }
blink = $80; DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
const { Add-in for blinking }
{$ifndef GO32V2} Blink = 128;
directvideo:boolean=true;
{$else GO32V2}
{ direct video generates a GPF in DPMI of setcursor }
directvideo:boolean=false;
{$endif GO32V2}
var var
{ for compatibility }
checkbreak,checkeof,checksnow : boolean;
lastmode : word; { screen mode} { Interface variables }
textattr : byte; { current text attribute } CheckBreak: Boolean; { Enable Ctrl-Break }
windmin : word; { upper right corner of the CRT window } CheckEOF: Boolean; { Enable Ctrl-Z }
windmax : word; { lower left corner of the CRT window } 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 }
function keypressed : boolean; { Interface procedures }
function readkey : char; procedure AssignCrt(var F: Text);
procedure gotoxy(x,y : byte); function KeyPressed: Boolean;
procedure window(left,top,right,bottom : byte); function ReadKey: Char;
procedure clrscr; procedure TextMode(Mode: Integer);
procedure textcolor(color : byte); procedure Window(X1,Y1,X2,Y2: Byte);
procedure textbackground(color : byte); procedure GotoXY(X,Y: Byte);
procedure assigncrt(var f : text); function WhereX: Byte;
function wherex : byte; function WhereY: Byte;
function wherey : byte; procedure ClrScr;
procedure delline; procedure ClrEol;
procedure delline(line : byte); procedure InsLine;
procedure clreol; procedure DelLine;
procedure insline; procedure TextColor(Color: Byte);
procedure cursoron; procedure TextBackground(Color: Byte);
procedure cursoroff; procedure LowVideo;
procedure cursorbig; procedure HighVideo;
procedure lowvideo; procedure NormVideo;
procedure highvideo; procedure Delay(MS: Word);
procedure nosound; procedure Sound(Hz: Word);
procedure sound(hz : word); procedure NoSound;
procedure delay(ms : longint);
procedure textmode(mode : integer);
procedure normvideo;
implementation
var
maxcols,maxrows : longint;
{ definition of textrec is in textrec.inc} {Extra Functions}
procedure cursoron;
procedure cursoroff;
procedure cursorbig;
{$i textrec.inc}
{ low level routines } implementation
uses
go32;
var
startattrib : byte;
col,row,
maxcols,maxrows : longint;
{
definition of textrec is in textrec.inc
}
{$i textrec.inc}
{****************************************************************************
Low level Routines
****************************************************************************}
function getscreenmode : byte; function getscreenmode : byte;
begin begin
dosmemget($40,$49,getscreenmode,1); dosmemget($40,$49,getscreenmode,1);
end; end;
@ -230,6 +210,8 @@ unit crt;
row:=0; row:=0;
dosmemget($40,$50,col,1); dosmemget($40,$50,col,1);
dosmemget($40,$51,row,1); dosmemget($40,$51,row,1);
inc(col);
inc(row);
end; end;
{ exported routines } { exported routines }
@ -397,7 +379,7 @@ unit crt;
begin begin
screengetcursor(row,col); screengetcursor(row,col);
wherex:=col-lo(windmin)+1; wherex:=col-lo(windmin);
end; end;
function wherey : byte; function wherey : byte;
@ -407,29 +389,23 @@ unit crt;
begin begin
screengetcursor(row,col); screengetcursor(row,col);
wherey:=row-hi(windmin)+1; wherey:=row-hi(windmin);
end; end;
procedure window(left,top,right,bottom : byte); procedure Window(X1,Y1,X2,Y2: Byte);
begin begin
if (left<1) or if (x1<1) or (x2>screencols) or (y2>screenrows) or
(right>screencols) or (x1>x2) or (y1>y2) then
(bottom>screenrows) or exit;
(left>right) or windmin:=(x1-1) or ((x1-1) shl 8);
(top>bottom) then windmax:=(x2-1) or ((y2-1) shl 8);
exit;
windmin:=(left-1) or ((top-1) shl 8);
windmax:=(right-1) or ((bottom-1) shl 8);
gotoxy(1,1); gotoxy(1,1);
end; end;
procedure clrscr; procedure clrscr;
var var
fil : word; fil : word;
row : longint; row : longint;
begin begin
fil:=32 or (textattr shl 8); fil:=32 or (textattr shl 8);
for row:=hi(windmin) to hi(windmax) do for row:=hi(windmin) to hi(windmax) do
@ -437,45 +413,41 @@ unit crt;
gotoxy(1,1); gotoxy(1,1);
end; end;
procedure textcolor(color : Byte);
procedure textcolor(color : Byte);
begin begin
textattr:=(textattr and $70) or color; textattr:=(textattr and $70) or color;
end; end;
procedure lowvideo;
procedure lowvideo;
begin begin
textattr:=textattr and $f7; textattr:=textattr and $f7;
end; end;
procedure highvideo;
procedure highvideo;
begin begin
textattr:=textattr or $08; textattr:=textattr or $08;
end; end;
procedure textbackground(color : Byte);
procedure textbackground(color : Byte);
begin begin
textattr:=(textattr and $8f) or ((color and $7) shl 4); textattr:=(textattr and $8f) or ((color and $7) shl 4);
end; end;
var
startattrib : byte;
procedure normvideo; procedure normvideo;
begin begin
textattr:=startattrib; textattr:=startattrib;
end; end;
procedure delline(line : byte);
procedure removeline(line : byte);
var var
row,left,right,bot : longint; row,left,right,bot : longint;
fil : word; fil : word;
begin begin
row:=line+hi(windmin); row:=line+hi(windmin);
left:=lo(windmin)+1; left:=lo(windmin)+1;
@ -490,10 +462,10 @@ unit crt;
dosmemfillword($b800,get_addr(bot,left),right-left+1,fil); dosmemfillword($b800,get_addr(bot,left),right-left+1,fil);
end; end;
procedure delline;
procedure delline;
begin begin
delline(wherey); removeline(wherey);
end; end;
procedure insline; procedure insline;
@ -518,11 +490,9 @@ unit crt;
end; end;
procedure clreol; procedure clreol;
var var
row,col : longint; row,col : longint;
fil : word; fil : word;
begin begin
screengetcursor(row,col); screengetcursor(row,col);
inc(row); inc(row);
@ -532,61 +502,52 @@ unit crt;
end; end;
Procedure WriteChar(c:char);
var
sa : longint;
regs : trealregs;
begin
case c of
#10 : inc(row);
#13 : col:=lo(windmin)+1;
#8 : begin
if col>lo(windmin)+1 then
dec(col);
end;
#7 : begin { beep }
regs.dl:=7;
regs.ah:=2;
realintr($21,regs);
end;
else
begin
sa:=(textattr shl 8) or byte(c);
dosmemput($b800,get_addr(row,col),sa,sizeof(sa));
inc(col);
end;
end;
if col>lo(windmax)+1 then
begin
col:=lo(windmin)+1;
inc(row);
end;
while row>hi(windmax)+1 do
begin
removeline(1);
dec(row);
end;
end;
Function CrtWrite(var f : textrec):integer; Function CrtWrite(var f : textrec):integer;
var var
i,col,row : longint; i : longint;
c : char;
va,sa : word;
begin begin
screengetcursor(row,col); screengetcursor(row,col);
inc(row); inc(row);
inc(col); inc(col);
va:=get_addr(row,col);
for i:=0 to f.bufpos-1 do for i:=0 to f.bufpos-1 do
begin WriteChar(f.buffer[i]);
c:=f.buffer[i];
case ord(c) of
10 : begin
inc(row);
va:=va+maxcols*2;
end;
13 : begin
col:=lo(windmin)+1;
va:=get_addr(row,col);
end;
8 : if col>lo(windmin)+1 then
begin
dec(col);
va:=va-2;
end;
7 : begin
{ beep }
end;
else
begin
sa:=textattr shl 8 or ord(c);
dosmemput($b800,va,sa,sizeof(sa));
inc(col);
va:=va+2;
end;
end;
if col>lo(windmax)+1 then
begin
col:=lo(windmin)+1;
inc(row);
{ it's easier to calculate the new address }
{ it don't spend much time }
va:=get_addr(row,col);
end;
while row>hi(windmax)+1 do
begin
delline(1);
dec(row);
va:=va-maxcols*2;
end;
end;
f.bufpos:=0; f.bufpos:=0;
screensetcursor(row-1,col-1); screensetcursor(row-1,col-1);
CrtWrite:=0; CrtWrite:=0;
@ -608,9 +569,7 @@ unit crt;
Function CrtRead(Var F: TextRec): Integer; Function CrtRead(Var F: TextRec): Integer;
Begin Begin
{$IFDEF GO32V2}
f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize); f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize);
{$ENDIF}
f.bufpos:=0; f.bufpos:=0;
CrtRead:=0; CrtRead:=0;
End; End;
@ -623,18 +582,13 @@ unit crt;
End; End;
End; End;
procedure assigncrt(var f : text); procedure AssignCrt(var F: Text);
begin begin
TextRec(F).Mode:=fmClosed; Assign(F,'.');
TextRec(F).BufSize:=SizeOf(TextBuf); TextRec(F).OpenFunc:=@CrtOpen;
TextRec(F).BufPtr:=@TextRec(F).Buffer; TextRec(F).InOutFunc:=@CrtInOut;
TextRec(F).BufPos:=0; TextRec(F).FlushFunc:=@CrtInOut;
TextRec(F).OpenFunc:=@CrtOpen; TextRec(F).CloseFunc:=@CrtClose;
TextRec(F).InOutFunc:=@CrtInOut;
TextRec(F).FlushFunc:=@CrtInOut;
TextRec(F).CloseFunc:=@CrtClose;
TextRec(F).Name[0]:='.';
TextRec(F).Name[1]:=#0;
end; end;
procedure sound(hz : word); procedure sound(hz : word);
@ -648,7 +602,7 @@ unit crt;
asm asm
movzwl hz,%ecx movzwl hz,%ecx
movl $1193046,%eax movl $1193046,%eax
cdq cdq
divl %ecx divl %ecx
movl %eax,%ecx movl %eax,%ecx
movb $0xb6,%al movb $0xb6,%al
@ -676,11 +630,9 @@ unit crt;
var var
calibration : longint; calibration : longint;
procedure delay(ms : longint); procedure Delay(MS: Word);
var var
i,j : longint; i,j : longint;
begin begin
for i:=1 to ms do for i:=1 to ms do
for j:=1 to calibration do for j:=1 to calibration do
@ -695,8 +647,10 @@ unit crt;
end; end;
procedure initdelay; procedure initdelay;
{ From the mailling list,
{ From the mailling list,
by Jonathan Anderson (sarlok@geocities.com) } by Jonathan Anderson (sarlok@geocities.com) }
const const
@ -739,7 +693,8 @@ unit crt;
if calibration<(threshold+1)*2 then if calibration<(threshold+1)*2 then
calibration:=(threshold+1)*2; calibration:=(threshold+1)*2;
{ If calibration is not at least this value, an } { If calibration is not at least this value, an }
{ infinite loop will result. } { infinite loop will result. }
@ -788,10 +743,8 @@ unit crt;
procedure textmode(mode : integer); procedure textmode(mode : integer);
var var
set_font8x8 : boolean; set_font8x8 : boolean;
begin begin
lastmode:=mode; lastmode:=mode;
set_font8x8:=(mode and font8x8)<>0; set_font8x8:=(mode and font8x8)<>0;
@ -803,8 +756,6 @@ unit crt;
maxrows:=screenrows; maxrows:=screenrows;
end; end;
var
col,row : longint;
begin begin
is_last:=false; is_last:=false;
@ -824,11 +775,9 @@ begin
{ redirect the standard output } { redirect the standard output }
assigncrt(Output); assigncrt(Output);
TextRec(Output).mode:=fmOutput;
{$IFDEF GO32V2}
assigncrt(Input); assigncrt(Input);
TextRec(Output).mode:=fmOutput;
TextRec(Input).mode:=fmInput; TextRec(Input).mode:=fmInput;
{$ENDIF GO32V2}
{ calculates delay calibration } { calculates delay calibration }
initdelay; initdelay;
@ -836,56 +785,12 @@ end.
{ {
$Log$ $Log$
Revision 1.1 1998-03-25 11:18:41 root Revision 1.2 1998-05-21 19:30:46 peter
Initial revision * objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.8 1998/01/26 11:56:39 michael
+ Added log at the end
Working file: rtl/dos/crt.pp
description:
----------------------------
revision 1.7
date: 1998/01/07 09:24:18; author: michael; state: Exp; lines: +7 -2
* Bug fixed in initdelay, avoiding possible infiniteloop.
----------------------------
revision 1.6
date: 1998/01/06 00:29:28; author: michael; state: Exp; lines: +2 -2
Implemented a system independent sequence of reset/rewrite/append fileopenfunc etc system \n (from Peter Vreman)
----------------------------
revision 1.5
date: 1998/01/05 16:52:15; author: michael; state: Exp; lines: +7 -3
+ Minor change making use of new GO32V2 feature (From Peter Vreman)
----------------------------
revision 1.4
date: 1998/01/05 13:47:01; author: michael; state: Exp; lines: +199 -127
* Bug fixes by Peter Vreman (pfv@worldonline.nl), discovered
when writing CRT examples.
Bug fix from mailing list also applied.
----------------------------
revision 1.3
date: 1997/12/12 13:14:36; author: pierre; state: Exp; lines: +33 -12
+ added handling of swap_vectors if under exceptions
i.e. swapvector is not dummy under go32v2
* bug in output, exceptions where not allways reset correctly
now the code in dpmiexcp is called from v2prt0.as exit routine
* in crt.pp corrected init_delay calibration loop
and added it for go32v2 also (was disabled before due to crashes !!)
the previous code did a wrong assumption on the time need to call
get_ticks compared to an internal loop without call
----------------------------
revision 1.2
date: 1997/12/01 12:15:44; author: michael; state: Exp; lines: +11 -5
+ added copyright reference in header.
----------------------------
revision 1.1
date: 1997/11/27 08:33:49; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:49; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
} }

978
rtl/dos/dos.pp
View File

File diff suppressed because it is too large Load Diff

24
rtl/dos/go32v2/emu387.pp
View File

@ -29,7 +29,7 @@ unit emu387;
implementation implementation
uses dxeload, dpmiexcp, strings; uses dxeload, dpmiexcp;
type type
emu_entry_type = function(exc : pexception_state) : longint; emu_entry_type = function(exc : pexception_state) : longint;
@ -123,10 +123,10 @@ unit emu387;
hp : ppchar; hp : ppchar;
hs, hs,
_envvar : string; _envvar : string;
eqpos,i : longint; eqpos : longint;
begin begin
_envvar:=upcase(envvar); _envvar:=upcase(envvar);
hp:=environ; hp:=envp;
getenv:=''; getenv:='';
while assigned(hp^) do while assigned(hp^) do
begin begin
@ -147,7 +147,7 @@ unit emu387;
cp : string; cp : string;
i : byte; i : byte;
have_80387 : boolean; have_80387 : boolean;
emu_p : pointer; emu_p : pointer;
const const
veryfirst : boolean = True; veryfirst : boolean = True;
@ -217,7 +217,13 @@ end.
{ {
$Log$ $Log$
Revision 1.3 1998-03-31 10:18:55 florian Revision 1.4 1998-05-21 19:30:51 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.3 1998/03/31 10:18:55 florian
* exit message removed * exit message removed
Revision 1.2 1998/03/26 12:23:17 peter Revision 1.2 1998/03/26 12:23:17 peter
@ -254,7 +260,13 @@ end.
{ {
$Log$ $Log$
Revision 1.3 1998-03-31 10:18:55 florian Revision 1.4 1998-05-21 19:30:51 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.3 1998/03/31 10:18:55 florian
* exit message removed * exit message removed
Revision 1.2 1998/03/26 12:23:17 peter Revision 1.2 1998/03/26 12:23:17 peter

404
rtl/dos/go32v2/system.pp
View File

@ -17,33 +17,46 @@ unit system;
{$I os.inc} {$I os.inc}
interface interface
{ include system-independent routine headers } { include system-independent routine headers }
{$I systemh.inc} {$I systemh.inc}
{$I heaph.inc} { include heap support headers }
const {$I heaph.inc}
seg0040 = $0040;
segA000 = $A000;
segB000 = $B000;
segB800 = $B800;
var
mem : array[0..$7fffffff] of byte absolute $0;
memw : array[0..$7fffffff] of word absolute $0;
meml : array[0..$7fffffff] of longint absolute $0;
const const
UnusedHandle=$ffff; { Default filehandles }
StdInputHandle=0; UnusedHandle = $ffff;
StdOutputHandle=1; StdInputHandle = 0;
StdErrorHandle=2; StdOutputHandle = 1;
StdErrorHandle = 2;
{ Default memory segments (Tp7 compatibility) }
seg0040 = $0040;
segA000 = $A000;
segB000 = $B000;
segB800 = $B800;
var
{ Mem[] support }
mem : array[0..$7fffffff] of byte absolute $0;
memw : array[0..$7fffffff] of word absolute $0;
meml : array[0..$7fffffff] of longint absolute $0;
{ C-compatible arguments and environment }
argc : longint;
argv : ppchar;
envp : ppchar;
dos_argv0 : pchar;
{ System info }
Win95 : boolean;
type type
t_stub_info = record { Dos Extender info }
p_stub_info = ^t_stub_info;
t_stub_info = packed record
magic : array[0..15] of char; magic : array[0..15] of char;
size : longint; size : longint;
minstack : longint; minstack : longint;
@ -58,146 +71,125 @@ type
basename : array[0..7] of char; basename : array[0..7] of char;
argv0 : array [0..15] of char; argv0 : array [0..15] of char;
dpmi_server : array [0..15] of char; dpmi_server : array [0..15] of char;
end; end;
p_stub_info = ^t_stub_info;
var stub_info : p_stub_info; p_go32_info_block = ^t_go32_info_block;
t_go32_info_block = packed record
{$PACKRECORDS 1} size_of_this_structure_in_bytes : longint; {offset 0}
type linear_address_of_primary_screen : longint; {offset 4}
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_secondary_screen : longint; {offset 8}
linear_address_of_transfer_buffer : longint; {offset 12} linear_address_of_transfer_buffer : longint; {offset 12}
size_of_transfer_buffer : longint; {offset 16} size_of_transfer_buffer : longint; {offset 16}
pid : longint; {offset 20} pid : longint; {offset 20}
master_interrupt_controller_base : byte; {offset 24} master_interrupt_controller_base : byte; {offset 24}
slave_interrupt_controller_base : byte; {offset 25} slave_interrupt_controller_base : byte; {offset 25}
selector_for_linear_memory : word; {offset 26} selector_for_linear_memory : word; {offset 26}
linear_address_of_stub_info_structure : longint; {offset 28} linear_address_of_stub_info_structure : longint; {offset 28}
linear_address_of_original_psp : longint; {offset 32} linear_address_of_original_psp : longint; {offset 32}
run_mode : word; {offset 36} run_mode : word; {offset 36}
run_mode_info : word; {offset 38} run_mode_info : word; {offset 38}
end; end;
var go32_info_block : t_go32_info_block; var
stub_info : p_stub_info;
go32_info_block : t_go32_info_block;
type
trealregs=record
realedi,realesi,realebp,realres,
realebx,realedx,realecx,realeax : longint;
realflags,
reales,realds,realfs,realgs,
realip,realcs,realsp,realss : word;
end;
var
dos_argv0 : pchar;
environ : ppchar;
{ Running under Win95 ? }
Win95 : boolean;
function do_write(h,addr,len : longint) : longint; {
function do_read(h,addr,len : longint) : longint; necessary for objects.pas, should be removed (at least from the interface
procedure syscopyfromdos(addr : longint; len : longint); to the implementation)
procedure syscopytodos(addr : longint; len : longint); }
function tb : longint; type
procedure sysrealintr(intnr : word;var regs : trealregs); trealregs=record
realedi,realesi,realebp,realres,
realebx,realedx,realecx,realeax : longint;
realflags,
reales,realds,realfs,realgs,
realip,realcs,realsp,realss : word;
end;
function do_write(h,addr,len : longint) : longint;
function do_read(h,addr,len : longint) : longint;
procedure syscopyfromdos(addr : longint; len : longint);
procedure syscopytodos(addr : longint; len : longint);
procedure sysrealintr(intnr : word;var regs : trealregs);
function tb : longint;
implementation
{ include system independent routines }
{$I system.inc} implementation
type { include system independent routines }
plongint = ^longint;
const carryflag = 1; {$I system.inc}
{$S-} const
procedure st1(stack_size : longint);[public,alias: 'STACKCHECK']; carryflag = 1;
begin type
{ called when trying to get local stack } plongint = ^longint;
{ 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 var
pushl %eax doscmd : string[128]; { Dos commandline copied from PSP, max is 128 chars }
pushl %ebx
movl stack_size,%ebx
movl %esp,%eax procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
subl %ebx,%eax {
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 !!
}
begin
asm
pushl %eax
pushl %ebx
movl stack_size,%ebx
movl %esp,%eax
subl %ebx,%eax
{$ifdef SYSTEMDEBUG} {$ifdef SYSTEMDEBUG}
movl U_SYSTEM_LOWESTSTACK,%ebx movl U_SYSTEM_LOWESTSTACK,%ebx
cmpl %eax,%ebx cmpl %eax,%ebx
jb _is_not_lowest jb _is_not_lowest
movl %eax,U_SYSTEM_LOWESTSTACK movl %eax,U_SYSTEM_LOWESTSTACK
_is_not_lowest: _is_not_lowest:
{$endif SYSTEMDEBUG} {$endif SYSTEMDEBUG}
movl __stkbottom,%ebx movl __stkbottom,%ebx
cmpl %eax,%ebx cmpl %eax,%ebx
jae __short_on_stack jae __short_on_stack
popl %ebx popl %ebx
popl %eax popl %eax
leave leave
ret $4 ret $4
__short_on_stack: __short_on_stack:
{ can be usefull for error recovery !! } { can be usefull for error recovery !! }
popl %ebx popl %ebx
popl %eax popl %eax
end['EAX','EBX']; end['EAX','EBX'];
RunError(202); RunError(202);
{ this needs a local variable } end;
{ so the function called itself !! }
{ Writeln('low in stack ');
RunError(202); }
end;
function tb : longint;
begin
tb := go32_info_block.linear_address_of_transfer_buffer;
{ asm
leal __go32_info_block,%ebx
movl 12(%ebx),%eax
leave
ret
end ['EAX','EBX'];}
end;
function tb_size : longint; function tb : longint;
begin begin
tb_size := go32_info_block.size_of_transfer_buffer; tb:=go32_info_block.linear_address_of_transfer_buffer;
{ asm end;
leal __go32_info_block,%ebx
movl 16(%ebx),%eax
leave
ret
end ['EAX','EBX'];}
end;
function dos_selector : word;
begin
dos_selector:=go32_info_block.selector_for_linear_memory;
{ asm
leal __go32_info_block,%ebx
movw 26(%ebx),%ax
movw %ax,__RESULT
end ['EAX','EBX'];}
end;
function get_ds : word; function tb_size : longint;
begin
tb_size:=go32_info_block.size_of_transfer_buffer;
end;
begin
asm function dos_selector : word;
movw %ds,%ax begin
movw %ax,__RESULT; dos_selector:=go32_info_block.selector_for_linear_memory;
end; end;
end;
function get_ds : word;assembler;
asm
movw %ds,%ax
end;
procedure sysseg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint); procedure sysseg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
@ -268,13 +260,6 @@ var go32_info_block : t_go32_info_block;
end ['ESI','EDI','ECX']; end ['ESI','EDI','ECX'];
end; end;
{ included directly old file sargs.inc }
var argc : longint;
doscmd : string;
args : ppchar;
function far_strlen(selector : word;linear_address : longint) : longint; function far_strlen(selector : word;linear_address : longint) : longint;
begin begin
asm asm
@ -294,6 +279,7 @@ asm
end; end;
end; end;
function atohex(s : pchar) : longint; function atohex(s : pchar) : longint;
var rv : longint; var rv : longint;
v : byte; v : byte;
@ -316,7 +302,7 @@ var psp : word;
i,j : byte; i,j : byte;
quote : char; quote : char;
proxy_s : string[7]; proxy_s : string[7];
tempargs : ppchar; tempargv : ppchar;
al,proxy_argc,proxy_seg,proxy_ofs,lin : longint; al,proxy_argc,proxy_seg,proxy_ofs,lin : longint;
largs : array[0..127] of pchar; largs : array[0..127] of pchar;
rm_argv : ^arrayword; rm_argv : ^arrayword;
@ -394,16 +380,17 @@ if (argc > 1) and (far_strlen(get_ds,longint(largs[1])) = 6) then
argc := proxy_argc; argc := proxy_argc;
end; end;
end; end;
getmem(args,argc*SizeOf(pchar)); getmem(argv,argc shl 2);
for i := 0 to argc-1 do for i := 0 to argc-1 do
args[i] := largs[i]; argv[i] := largs[i];
tempargs:=args; tempargv:=argv;
asm asm
movl tempargs,%eax movl tempargv,%eax
movl %eax,_args movl %eax,_args
end; end;
end; end;
function strcopy(dest,source : pchar) : pchar; function strcopy(dest,source : pchar) : pchar;
begin begin
@ -454,36 +441,37 @@ begin
while (cp^ <> #0) do inc(longint(cp)); { skip to NUL } while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
inc(longint(cp)); { skip to next character } inc(longint(cp)); { skip to next character }
end; end;
getmem(environ,(env_count+1) * sizeof(pchar)); getmem(envp,(env_count+1) * sizeof(pchar));
if (environ = nil) then exit; if (envp = nil) then exit;
cp:=dos_env; cp:=dos_env;
env_count:=0; env_count:=0;
while cp^ <> #0 do while cp^ <> #0 do
begin begin
getmem(environ[env_count],strlen(cp)+1); getmem(envp[env_count],strlen(cp)+1);
strcopy(environ[env_count], cp); strcopy(envp[env_count], cp);
{$IfDef SYSTEMDEBUG} {$IfDef SYSTEMDEBUG}
Writeln('env ',env_count,' = "',environ[env_count],'"'); Writeln('env ',env_count,' = "',envp[env_count],'"');
{$EndIf SYSTEMDEBUG} {$EndIf SYSTEMDEBUG}
inc(env_count); inc(env_count);
while (cp^ <> #0) do inc(longint(cp)); { skip to NUL } while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
inc(longint(cp)); { skip to next character } inc(longint(cp)); { skip to next character }
end; end;
environ[env_count]:=nil; envp[env_count]:=nil;
inc(longint(cp),3); inc(longint(cp),3);
getmem(dos_argv0,strlen(cp)+1); getmem(dos_argv0,strlen(cp)+1);
if (dos_argv0 = nil) then halt; if (dos_argv0 = nil) then halt;
strcopy(dos_argv0, cp); strcopy(dos_argv0, cp);
end; end;
procedure syscopytodos(addr : longint; len : longint); procedure syscopytodos(addr : longint; len : longint);
begin begin
if len > tb_size then runerror(200); if len > tb_size then runerror(217);
sysseg_move(get_ds,addr,dos_selector,tb,len); sysseg_move(get_ds,addr,dos_selector,tb,len);
end; end;
procedure syscopyfromdos(addr : longint; len : longint); procedure syscopyfromdos(addr : longint; len : longint);
begin begin
if len > tb_size then runerror(200); if len > tb_size then runerror(217);
sysseg_move(dos_selector,tb,get_ds,addr,len); sysseg_move(dos_selector,tb,get_ds,addr,len);
end; end;
@ -496,8 +484,6 @@ end;
movw intnr,%bx movw intnr,%bx
xorl %ecx,%ecx xorl %ecx,%ecx
movl regs,%edi movl regs,%edi
// es is always equal ds
movw $0x300,%ax movw $0x300,%ax
int $0x31 int $0x31
end; end;
@ -519,60 +505,47 @@ end;
end; end;
end; end;
function paramcount : longint; function paramcount : longint;
begin
paramcount := argc - 1;
end;
begin
paramcount := argc - 1;
{ asm
movl _argc,%eax
decl %eax
leave
ret
end ['EAX'];}
end;
function paramstr(l : longint) : string; function paramstr(l : longint) : string;
begin
if (l>=0) and (l+1<=argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
var
p : ^pchar;
begin procedure randomize;
if (l>=0) and (l<=paramcount) then var
begin hl : longint;
p:=args; regs : trealregs;
paramstr:=strpas(p[l]); begin
end regs.realeax:=$2c00;
else paramstr:=''; sysrealintr($21,regs);
end; hl:=regs.realedx and $ffff;
randseed:=hl*$10000+ (regs.realecx and $ffff);
end;
procedure randomize; {*****************************************************************************
Heap Management
*****************************************************************************}
var function Sbrk(size : longint):longint;assembler;
hl : longint; asm
regs : trealregs; movl size,%eax
pushl %eax
call ___sbrk
addl $4,%esp
end;
begin { include standard heap management }
regs.realeax:=$2c00; {$I heap.inc}
sysrealintr($21,regs);
hl:=regs.realedx and $ffff;
randseed:=hl*$10000+ (regs.realecx and $ffff);
end;
{ use standard heap management }
function Sbrk(size : longint) : longint;
begin
asm
movl size,%eax
pushl %eax
call ___sbrk
addl $4,%esp
movl %eax,__RESULT
end;
end;
{$i heap.inc}
{**************************************************************************** {****************************************************************************
Low level File Routines Low level File Routines
@ -768,7 +741,6 @@ begin
end; end;
function do_filesize(handle : longint) : longint; function do_filesize(handle : longint) : longint;
var var
aktfilepos : longint; aktfilepos : longint;
@ -960,7 +932,7 @@ begin
end end
else else
syscopyfromdos(longint(@temp),251); syscopyfromdos(longint(@temp),251);
{ conversation to Pascal string } { conversation to Pascal string including slash conversion }
i:=0; i:=0;
while (temp[i]<>#0) do while (temp[i]<>#0) do
begin begin
@ -972,7 +944,7 @@ begin
dir[2]:=':'; dir[2]:=':';
dir[3]:='\'; dir[3]:='\';
dir[0]:=chr(i+3); dir[0]:=chr(i+3);
{ upcase the string (FPKPascal function) } { upcase the string }
dir:=upcase(dir); dir:=upcase(dir);
if drivenr<>0 then { Drive was supplied. We know it } if drivenr<>0 then { Drive was supplied. We know it }
dir[1]:=chr(65+drivenr-1) dir[1]:=chr(65+drivenr-1)
@ -999,7 +971,7 @@ begin
regs.realeax:=$160a; regs.realeax:=$160a;
sysrealintr($2f,regs); sysrealintr($2f,regs);
CheckWin95:=(regs.realeax=0) and ((regs.realebx and $ff00)=$400); CheckWin95:=(regs.realeax=0) and ((regs.realebx and $ff00)=$400);
end; end;
procedure OpenStdIO(var f:text;mode:word;hdl:longint); procedure OpenStdIO(var f:text;mode:word;hdl:longint);
@ -1012,7 +984,7 @@ begin
TextRec(f).Closefunc:=@fileclosefunc; TextRec(f).Closefunc:=@fileclosefunc;
end; end;
Begin Begin
{ Initialize ExitProc } { Initialize ExitProc }
ExitProc:=Nil; ExitProc:=Nil;
@ -1029,12 +1001,18 @@ Begin
Setup_Arguments; Setup_Arguments;
{ Use Win95 LFN } { Use Win95 LFN }
Win95:=CheckWin95; Win95:=CheckWin95;
{ Reset IO Error } { Reset IO Error }
InOutRes:=0; InOutRes:=0;
End. End.
{ {
$Log$ $Log$
Revision 1.4 1998-05-04 17:58:41 peter Revision 1.5 1998-05-21 19:30:52 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.4 1998/05/04 17:58:41 peter
* fix for smartlinking with _ARGS * fix for smartlinking with _ARGS
Revision 1.3 1998/05/04 16:21:54 florian Revision 1.3 1998/05/04 16:21:54 florian

56
rtl/inc/file.inc
View File

@ -31,6 +31,24 @@ Begin
End; End;
Procedure assign(var f:File;p:pchar);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,StrPas(p));
end;
Procedure assign(var f:File;c:char);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,string(c));
end;
Procedure Rewrite(var f:File;l:Word);[IOCheck]; Procedure Rewrite(var f:File;l:Word);[IOCheck];
{ {
Create file f with recordsize of l Create file f with recordsize of l
@ -242,22 +260,44 @@ Begin
End; End;
Procedure Rename(var f : File;p:pchar);[IOCheck];
Begin
If FileRec(f).mode=fmClosed Then
Begin
Do_Rename(PChar(@FileRec(f).Name),p);
Move(p,FileRec(f).Name,StrLen(p)+1);
End;
End;
Procedure Rename(var f : File;const s : string);[IOCheck]; Procedure Rename(var f : File;const s : string);[IOCheck];
var var
p : array[0..255] Of Char; p : array[0..255] Of Char;
Begin Begin
If FileRec(f).mode=fmClosed Then Move(s[1],p,Length(s));
Begin p[Length(s)]:=#0;
Move(s[1],p,Length(s)); Rename(f,Pchar(@p));
p[Length(s)]:=#0; End;
Do_Rename(PChar(@FileRec(f).Name),PChar(@p));
Move(p,FileRec(f).Name,Length(s)+1);
End; Procedure Rename(var f : File;c : char);[IOCheck];
var
p : array[0..1] Of Char;
Begin
p[0]:=c;
p[1]:=#0;
Rename(f,Pchar(@p));
End; End;
{ {
$Log$ $Log$
Revision 1.2 1998-05-12 10:42:44 peter Revision 1.3 1998-05-21 19:30:56 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.2 1998/05/12 10:42:44 peter
* moved getopts to inc/, all supported OS's need argc,argv exported * moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit + strpas, strlen are now exported in the systemunit
* removed logs * removed logs

78
rtl/inc/getopts.pp
View File

@ -6,7 +6,6 @@
Getopt implementation for Free Pascal, modeled after GNU getopt. Getopt implementation for Free Pascal, modeled after GNU getopt.
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -17,8 +16,6 @@
**********************************************************************} **********************************************************************}
unit getopts; unit getopts;
{$I os.inc}
{ -------------------------------------------------------------------- { --------------------------------------------------------------------
*NOTE* *NOTE*
The routines are a more or less straightforward conversion The routines are a more or less straightforward conversion
@ -33,16 +30,14 @@ Interface
Const No_Argument = 0; Const No_Argument = 0;
Required_Argument = 1; Required_Argument = 1;
Optional_Argument = 2; Optional_Argument = 2;
EndOfOptions = #255; EndOfOptions = #255;
Type TOption = Record Type TOption = Record
Name : String; Name : String;
Has_arg : Integer; Has_arg : Integer;
Flag : PChar; Flag : PChar;
Value : Char; Value : Char;
end; end;
POption = ^TOption; POption = ^TOption;
Orderings = (require_order,permute,return_in_order); Orderings = (require_order,permute,return_in_order);
@ -51,13 +46,8 @@ Var OptArg : String;
OptErr : Boolean; OptErr : Boolean;
OptOpt : Char; OptOpt : Char;
Function GetOpt (ShortOpts : String) : char; Function GetOpt (ShortOpts : String) : char;
Function GetLongOpts (ShortOpts : String; Function GetLongOpts (ShortOpts : String;LongOpts : POption;var Longind : Integer) : char;
LongOpts : POption;
var Longind : Integer) : char;
Implementation Implementation
@ -68,8 +58,6 @@ Var
last_nonopt : Longint; last_nonopt : Longint;
Ordering : Orderings; Ordering : Orderings;
Procedure Exchange; Procedure Exchange;
var var
bottom, bottom,
@ -120,28 +108,26 @@ begin
OptOpt:='?'; OptOpt:='?';
Nextchar:=0; Nextchar:=0;
if opts[1]='-' then if opts[1]='-' then
begin
ordering:=return_in_order;
delete(opts,1,1);
end
else
if opts[1]='+' then
begin begin
ordering:=return_in_order; ordering:=require_order;
delete(opts,1,1); delete(opts,1,1);
end end
else if opts[1]='+' then else
begin ordering:=permute;
ordering:=require_order;
delete(opts,1,1);
end
else ordering:=permute;
end; end;
Function Internal_getopt (Var Optstring : string; Function Internal_getopt (Var Optstring : string;LongOpts : POption;
LongOpts : POption; LongInd : pointer;Long_only : boolean ) : char;
LongInd : pointer;
Long_only : boolean ) : char;
type type
pinteger=^integer; pinteger=^integer;
var var
temp,endopt,option_index : byte; temp,endopt,option_index : byte;
indfound: integer; indfound: integer;
@ -149,7 +135,6 @@ var
p,pfound : POption; p,pfound : POption;
exact,ambig : boolean; exact,ambig : boolean;
c : char; c : char;
begin begin
optarg:=''; optarg:='';
if optind=0 then if optind=0 then
@ -157,7 +142,6 @@ begin
{ Check if We need the next argument. } { Check if We need the next argument. }
if optind<nrargs then currentarg:=strpas(argv[optind]) else currentarg:=''; if optind<nrargs then currentarg:=strpas(argv[optind]) else currentarg:='';
if (nextchar=0) then if (nextchar=0) then
begin begin
if ordering=permute then if ordering=permute then
begin begin
@ -183,13 +167,11 @@ begin
if (first_nonopt<>last_nonopt) and (last_nonopt<>optind) then if (first_nonopt<>last_nonopt) and (last_nonopt<>optind) then
exchange exchange
else else
if first_nonopt=last_nonopt then if first_nonopt=last_nonopt then
first_nonopt:=optind; first_nonopt:=optind;
last_nonopt:=nrargs; last_nonopt:=nrargs;
optind:=nrargs; optind:=nrargs;
end; end;
{ Are we at the end of all arguments ? } { Are we at the end of all arguments ? }
if optind>=nrargs then if optind>=nrargs then
begin begin
@ -226,7 +208,6 @@ begin
end; end;
{ Check if we have a long option } { Check if we have a long option }
if longopts<>nil then if longopts<>nil then
if length(currentarg)>1 then if length(currentarg)>1 then
if (currentarg[2]='-') or if (currentarg[2]='-') or
((not long_only) and (pos(currentarg[2],optstring)<>0)) then ((not long_only) and (pos(currentarg[2],optstring)<>0)) then
@ -266,7 +247,6 @@ begin
inc (option_index); inc (option_index);
end; end;
if ambig and not exact then if ambig and not exact then
begin begin
if opterr then if opterr then
writeln (paramstr(0),': option "',optname,'" is ambiguous'); writeln (paramstr(0),': option "',optname,'" is ambiguous');
@ -287,16 +267,13 @@ begin
if currentarg[2]='-' then if currentarg[2]='-' then
writeln (paramstr(0),': option "--',pfound^.name,'" doesn''t allow an argument') writeln (paramstr(0),': option "--',pfound^.name,'" doesn''t allow an argument')
else else
writeln (paramstr(0),': option "',currentarg[1],pfound^.name,'" doesn''t allow an argument'); writeln (paramstr(0),': option "',currentarg[1],pfound^.name,'" doesn''t allow an argument');
nextchar:=0; nextchar:=0;
internal_getopt:='?'; internal_getopt:='?';
exit; exit;
end; end;
end end
else { argument in next paramstr... } else { argument in next paramstr... }
begin begin
if pfound^.has_arg=1 then if pfound^.has_arg=1 then
begin begin
@ -317,13 +294,11 @@ begin
exit; exit;
end; end;
end; end;
end; { argument in next parameter end;} end; { argument in next parameter end;}
nextchar:=0; nextchar:=0;
if longind<>nil then if longind<>nil then
pinteger(longind)^:=indfound+1; pinteger(longind)^:=indfound+1;
if pfound^.flag<>nil then if pfound^.flag<>nil then
begin begin
pfound^.flag^:=pfound^.value; pfound^.flag^:=pfound^.value;
internal_getopt:=#0; internal_getopt:=#0;
@ -346,14 +321,12 @@ begin
Internal_getopt:='?'; Internal_getopt:='?';
exit; exit;
end; end;
end; { Of long options.} end; { Of long options.}
{ We check for a short option. } { We check for a short option. }
temp:=pos(currentarg[nextchar],optstring); temp:=pos(currentarg[nextchar],optstring);
c:=currentarg[nextchar]; c:=currentarg[nextchar];
inc(nextchar); inc(nextchar);
if nextchar>length(currentarg) then if nextchar>length(currentarg) then
begin begin
inc(optind); inc(optind);
nextchar:=0; nextchar:=0;
@ -368,7 +341,6 @@ begin
end; end;
Internal_getopt:=optstring[temp]; Internal_getopt:=optstring[temp];
if optstring[temp+1]=':' then if optstring[temp+1]=':' then
if currentarg[temp+2]=':' then if currentarg[temp+2]=':' then
begin { optional argument } begin { optional argument }
optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1); optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1);
@ -377,7 +349,6 @@ begin
else else
begin { required argument } begin { required argument }
if nextchar>0 then if nextchar>0 then
begin begin
optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1); optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1);
inc(optind) inc(optind)
@ -389,11 +360,9 @@ begin
writeln (paramstr(0),': option requires an argument -- ',optstring[temp]); writeln (paramstr(0),': option requires an argument -- ',optstring[temp]);
optopt:=optstring[temp]; optopt:=optstring[temp];
if optstring[1]=':' then if optstring[1]=':' then
Internal_getopt:=':' Internal_getopt:=':'
else else
Internal_Getopt:='?' Internal_Getopt:='?'
end end
else else
begin begin
@ -411,31 +380,28 @@ begin
end; end;
Function GetLongOpts(ShortOpts : String; Function GetLongOpts (ShortOpts : String;LongOpts : POption;var Longind : Integer) : char;
LongOpts : POption;
var Longind : Integer) : char;
begin begin
getlongopts:=internal_getopt ( shortopts,longopts,@longind,true); getlongopts:=internal_getopt ( shortopts,longopts,@longind,true);
end; end;
begin begin
{ Needed to detect startup } { Needed to detect startup }
Opterr:=true; Opterr:=true;
Optind:=0; Optind:=0;
nrargs:=paramcount+1; nrargs:=paramcount+1;
end. end.
{ {
$Log$ $Log$
Revision 1.1 1998-05-12 10:42:45 peter Revision 1.2 1998-05-21 19:30:57 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.1 1998/05/12 10:42:45 peter
* moved getopts to inc/, all supported OS's need argc,argv exported * moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit + strpas, strlen are now exported in the systemunit
* removed logs * removed logs

29
rtl/inc/objects.pp
View File

@ -1,3 +1,6 @@
{
$Id$
}
{************[ SOURCE FILE OF FREE VISION ]****************} {************[ SOURCE FILE OF FREE VISION ]****************}
{ } { }
{ System independent clone of objects.pas } { System independent clone of objects.pas }
@ -85,16 +88,20 @@ UNIT Objects;
{==== Compiler directives ===========================================} {==== Compiler directives ===========================================}
{$IFNDEF FPC}
{ FPC doesn't support these switches in 0.99.5 }
{$F+} { Force far calls }
{$A+} { Word Align Data }
{$B-} { Allow short circuit boolean evaluations }
{$ENDIF}
{$E+} { Emulation is on } {$E+} { Emulation is on }
{$X+} { Extended syntax is ok } {$X+} { Extended syntax is ok }
{$F+} { Force far calls }
{$A+} { Word Align Data }
{$R-} { Disable range checking } {$R-} { Disable range checking }
{$S-} { Disable Stack Checking } {$S-} { Disable Stack Checking }
{$I-} { Disable IO Checking } {$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking } {$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings } {$V-} { Turn off strict VAR strings }
{$B-} { Allow short circuit boolean evaluations }
{====================================================================} {====================================================================}
{***************************************************************************} {***************************************************************************}
@ -1586,7 +1593,7 @@ END;
{ ChangeListSize -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB } { ChangeListSize -> Platforms DOS/DPMI/WIN/OS2 - Checked 19May96 LdB }
{---------------------------------------------------------------------------} {---------------------------------------------------------------------------}
FUNCTION TMemoryStream.ChangeListSize (ALimit: Sw_Word): Boolean; FUNCTION TMemoryStream.ChangeListSize (ALimit: Sw_Word): Boolean;
VAR I, W: Word; Li, Ti: LongInt; P: PPointerArray; VAR I, W: Word; Li: LongInt; P: PPointerArray;
BEGIN BEGIN
If (ALimit <> BlkCount) Then Begin { Change is needed } If (ALimit <> BlkCount) Then Begin { Change is needed }
ChangeListSize := False; { Preset failure } ChangeListSize := False; { Preset failure }
@ -1946,7 +1953,7 @@ END;
{---------------------------------------------------------------------------} {---------------------------------------------------------------------------}
PROCEDURE TCollection.Store (Var S: TStream); PROCEDURE TCollection.Store (Var S: TStream);
PROCEDURE DoPutItem (P: Pointer); FAR; PROCEDURE DoPutItem (P: Pointer);{$IFNDEF FPC}FAR;{$ENDIF}
BEGIN BEGIN
PutItem(S, P); { Put item on stream } PutItem(S, P); { Put item on stream }
END; END;
@ -2018,6 +2025,7 @@ END;
FUNCTION TSortedCollection.Compare (Key1, Key2: Pointer): Sw_Integer; FUNCTION TSortedCollection.Compare (Key1, Key2: Pointer): Sw_Integer;
BEGIN BEGIN
Abstract; { Abstract method } Abstract; { Abstract method }
Compare:=0;
END; END;
{--TSortedCollection--------------------------------------------------------} {--TSortedCollection--------------------------------------------------------}
@ -2409,7 +2417,7 @@ END;
FUNCTION TResourceFile.SwitchTo (AStream: PStream; Pack: Boolean): PStream; FUNCTION TResourceFile.SwitchTo (AStream: PStream; Pack: Boolean): PStream;
VAR NewBasePos: LongInt; VAR NewBasePos: LongInt;
PROCEDURE DoCopyResource (Item: PResourceItem); FAR; PROCEDURE DoCopyResource (Item: PResourceItem);{$IFNDEF FPC}FAR;{$ENDIF}
BEGIN BEGIN
Stream^.Seek(BasePos + Item^.Posn); { Move stream position } Stream^.Seek(BasePos + Item^.Posn); { Move stream position }
Item^.Posn := AStream^.GetPos - NewBasePos; { Hold new position } Item^.Posn := AStream^.GetPos - NewBasePos; { Hold new position }
@ -2719,3 +2727,12 @@ END;
END. END.
{
$Log$
Revision 1.2 1998-05-21 19:30:58 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
}

11
rtl/inc/platform.inc
View File

@ -1,4 +1,5 @@
{***************************************************************************** {*****************************************************************************
$Id$
Include file to sort out compilers/platforms/targets Include file to sort out compilers/platforms/targets
Copyright (c) 1997 Balazs Scheidler (bazsi@tas.vein.hu) Copyright (c) 1997 Balazs Scheidler (bazsi@tas.vein.hu)
@ -8,7 +9,6 @@
License as published by the Free Software Foundation; either License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version. version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful, This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
@ -120,3 +120,12 @@
Requires Free Pascal (FPK) v0.9.2 or higher Requires Free Pascal (FPK) v0.9.2 or higher
{$ENDIF} {$ENDIF}
{
$Log$
Revision 1.2 1998-05-21 19:30:59 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
}

24
rtl/inc/systemh.inc
View File

@ -32,7 +32,8 @@ Type
shortint = -128..127; shortint = -128..127;
byte = 0..255; byte = 0..255;
Word = 0..65535; Word = 0..65535;
{ at least declare Turbo Pascal real types } { at least declare Turbo Pascal real types }
{$IFDEF i386} {$IFDEF i386}
Double = real; Double = real;
@ -53,7 +54,8 @@ const
{ max. values for longint and int} { max. values for longint and int}
maxLongint = $7fffffff; maxLongint = $7fffffff;
maxint = 32767; maxint = 32767;
{ Compatibility With TP } { Compatibility With TP }
{$ifdef i386} {$ifdef i386}
Test8086 : byte = 2; { Always i386 or newer } Test8086 : byte = 2; { Always i386 or newer }
@ -236,6 +238,8 @@ Procedure Val(const s:string;Var v:cardinal);
****************************************************************************} ****************************************************************************}
Procedure Assign(Var f:File;const Name:string); Procedure Assign(Var f:File;const Name:string);
Procedure Assign(Var f:File;p:pchar);
Procedure Assign(Var f:File;c:char);
Procedure Rewrite(Var f:File;l:Word); Procedure Rewrite(Var f:File;l:Word);
Procedure Rewrite(Var f:File); Procedure Rewrite(Var f:File);
Procedure Reset(Var f:File;l:Word); Procedure Reset(Var f:File;l:Word);
@ -255,6 +259,8 @@ Procedure Seek(Var f:File;Pos:Longint);
Function EOF(Var f:File):Boolean; Function EOF(Var f:File):Boolean;
Procedure Erase(Var f:File); Procedure Erase(Var f:File);
Procedure Rename(Var f:File;const s:string); Procedure Rename(Var f:File;const s:string);
Procedure Rename(Var f:File;p:pchar);
Procedure Rename(Var f:File;c:char);
Procedure Truncate (Var F:File); Procedure Truncate (Var F:File);
{**************************************************************************** {****************************************************************************
@ -262,6 +268,8 @@ Procedure Truncate (Var F:File);
****************************************************************************} ****************************************************************************}
Procedure Assign(Var f:TypedFile;const Name:string); Procedure Assign(Var f:TypedFile;const Name:string);
Procedure Assign(Var f:TypedFile;p:pchar);
Procedure Assign(Var f:TypedFile;c:char);
Procedure Rewrite(Var f:TypedFile); Procedure Rewrite(Var f:TypedFile);
Procedure Reset(Var f:TypedFile); Procedure Reset(Var f:TypedFile);
@ -270,6 +278,8 @@ Procedure Reset(Var f:TypedFile);
****************************************************************************} ****************************************************************************}
Procedure Assign(Var t:Text;const s:string); Procedure Assign(Var t:Text;const s:string);
Procedure Assign(Var t:Text;p:pchar);
Procedure Assign(Var t:Text;c:char);
Procedure Close(Var t:Text); Procedure Close(Var t:Text);
Procedure Rewrite(Var t:Text); Procedure Rewrite(Var t:Text);
Procedure Reset(Var t:Text); Procedure Reset(Var t:Text);
@ -277,6 +287,8 @@ Procedure Append(Var t:Text);
Procedure Flush(Var t:Text); Procedure Flush(Var t:Text);
Procedure Erase(Var t:Text); Procedure Erase(Var t:Text);
Procedure Rename(Var t:Text;const s:string); Procedure Rename(Var t:Text;const s:string);
Procedure Rename(Var t:Text;p:pchar);
Procedure Rename(Var t:Text;c:char);
Function EOF(Var t:Text):Boolean; Function EOF(Var t:Text):Boolean;
Function EOF:Boolean; Function EOF:Boolean;
Function EOLn(Var t:Text):Boolean; Function EOLn(Var t:Text):Boolean;
@ -320,7 +332,13 @@ Procedure AddExitProc(Proc:TProcedure);
{ {
$Log$ $Log$
Revision 1.5 1998-05-12 10:42:45 peter Revision 1.6 1998-05-21 19:31:00 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.5 1998/05/12 10:42:45 peter
* moved getopts to inc/, all supported OS's need argc,argv exported * moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit + strpas, strlen are now exported in the systemunit
* removed logs * removed logs

87
rtl/inc/text.inc
View File

@ -77,6 +77,18 @@ Begin
End; End;
Procedure assign(var t:Text;p:pchar);
begin
Assign(t,StrPas(p));
end;
Procedure assign(var t:Text;c:char);
begin
Assign(t,string(c));
end;
Procedure Close(var t : Text);[Public,Alias: 'CLOSE_TEXT',IOCheck]; Procedure Close(var t : Text);[Public,Alias: 'CLOSE_TEXT',IOCheck];
Begin Begin
If (TextRec(t).mode<>fmClosed) Then If (TextRec(t).mode<>fmClosed) Then
@ -149,20 +161,36 @@ Begin
End; End;
Procedure Rename(var t:Text;const s:String);[IOCheck]; Procedure Rename(var t : text;p:pchar);[IOCheck];
var
p : array[0..255] Of Char;
Begin Begin
If TextRec(t).mode=fmClosed Then If TextRec(t).mode=fmClosed Then
Begin Begin
Move(s[1],p,Length(s)); Do_Rename(PChar(@TextRec(t).Name),p);
p[Length(s)]:=#0; Move(p,TextRec(t).Name,StrLen(p)+1);
Do_Rename(PChar(@TextRec(t).Name),PChar(@p));
Move(p,TextRec(t).Name,Length(s)+1);
End; End;
End; End;
Procedure Rename(var t : Text;const s : string);[IOCheck];
var
p : array[0..255] Of Char;
Begin
Move(s[1],p,Length(s));
p[Length(s)]:=#0;
Rename(t,Pchar(@p));
End;
Procedure Rename(var t : Text;c : char);[IOCheck];
var
p : array[0..1] Of Char;
Begin
p[0]:=c;
p[1]:=#0;
Rename(t,Pchar(@p));
End;
Function Eof(Var t: Text): Boolean;[IOCheck]; Function Eof(Var t: Text): Boolean;[IOCheck];
Begin Begin
{$IFNDEF EXTENDED_EOF} {$IFNDEF EXTENDED_EOF}
@ -678,8 +706,41 @@ Begin
{ copy string. } { copy string. }
Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos); Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
Inc(Longint(p),Temp-f.BufPos); Inc(Longint(p),Temp-f.BufPos);
If p^=#13 Then If pchar(p-1)^=#13 Then
dec(Longint(p)); dec(p);
{ update f.BufPos }
f.BufPos:=Temp;
If Temp>=f.BufEnd Then
Begin
FileFunc(f.InOutFunc)(f);
Temp:=f.BufPos;
End
End;
p^:=#0;
End;
Procedure r(var f : TextRec;var s : array00);[Public,Alias:'READ_TEXT_PCHAR_AS_ARRAY'];
var
p : PChar;
Temp : byte;
Begin
{ Delete the string }
s[0]:=#0;
p:=pchar(@s);
if not OpenInput(f) then
exit;
Temp:=f.BufPos;
while (f.BufPos<f.BufEnd) and (f.Bufptr^[Temp]<>#10) Do
Begin
{ search linefeed }
while (f.Bufptr^[Temp]<>#10) and (Temp<f.BufEnd) Do
inc(Temp);
{ copy string. }
Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
Inc(Longint(p),Temp-f.BufPos);
If pchar(p-1)^=#13 Then
dec(p);
{ update f.BufPos } { update f.BufPos }
f.BufPos:=Temp; f.BufPos:=Temp;
If Temp>=f.BufEnd Then If Temp>=f.BufEnd Then
@ -887,7 +948,13 @@ Begin
End; End;
{ {
$Log$ $Log$
Revision 1.5 1998-05-12 10:42:45 peter Revision 1.6 1998-05-21 19:31:01 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.5 1998/05/12 10:42:45 peter
* moved getopts to inc/, all supported OS's need argc,argv exported * moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit + strpas, strlen are now exported in the systemunit
* removed logs * removed logs

29
rtl/inc/typefile.inc
View File

@ -17,6 +17,9 @@
****************************************************************************} ****************************************************************************}
Procedure assign(var f:TypedFile;const Name:string); Procedure assign(var f:TypedFile;const Name:string);
{
Assign Name to file f so it can be used with the file routines
}
Begin Begin
FillChar(f,SizeOF(FileRec),0); FillChar(f,SizeOF(FileRec),0);
FileRec(f).Handle:=UnusedHandle; FileRec(f).Handle:=UnusedHandle;
@ -25,6 +28,24 @@ Begin
End; End;
Procedure assign(var f:TypedFile;p:pchar);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,StrPas(p));
end;
Procedure assign(var f:TypedFile;c:char);
{
Assign Name to file f so it can be used with the file routines
}
begin
Assign(f,string(c));
end;
Procedure Int_Typed_Reset(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias: 'RESET_TYPED']; Procedure Int_Typed_Reset(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias: 'RESET_TYPED'];
Begin Begin
Reset(UnTypedFile(f),Size); Reset(UnTypedFile(f),Size);
@ -54,7 +75,13 @@ End;
{ {
$Log$ $Log$
Revision 1.2 1998-05-12 10:42:45 peter Revision 1.3 1998-05-21 19:31:02 peter
* objects compiles for linux
+ assign(pchar), assign(char), rename(pchar), rename(char)
* fixed read_text_as_array
+ read_text_as_pchar which was not yet in the rtl
Revision 1.2 1998/05/12 10:42:45 peter
* moved getopts to inc/, all supported OS's need argc,argv exported * moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit + strpas, strlen are now exported in the systemunit
* removed logs * removed logs

4
rtl/linux/makefile
View File

@ -232,8 +232,10 @@ crt$(PPUEXT) : crt.pp $(INC)/textrec.inc $(INC)/filerec.inc linux$(PPUEXT)\
$(SYSTEMPPU) $(SYSTEMPPU)
$(PP) $(OPT) crt $(REDIR) $(PP) $(OPT) crt $(REDIR)
objects$(PPUEXT) : objects.pp $(SYSTEMPPU) objects$(PPUEXT) : $(INC)/objects.pp objinc.inc $(SYSTEMPPU)
$(COPY) $(INC)/objects.pp .
$(PP) $(OPT) objects $(REDIR) $(PP) $(OPT) objects $(REDIR)
$(DEL) objects.pp
printer$(PPUEXT) : printer.pp $(INC)/textrec.inc linux$(PPUEXT) $(SYSTEMPPU) printer$(PPUEXT) : printer.pp $(INC)/textrec.inc linux$(PPUEXT) $(SYSTEMPPU)
$(PP) $(OPT) printer $(REDIR) $(PP) $(OPT) printer $(REDIR)

8
rtl/linux/objinc.inc
View File

@ -56,12 +56,20 @@ BEGIN
END; END;
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word; FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
{$IFDEF DOSSETFILE1}
VAR Actual, Buf: LongInt; VAR Actual, Buf: LongInt;
{$ENDIF}
BEGIN BEGIN
if Sys_Truncate(Handle,FileSize)=0 then
SetFileSize:=0
else
SetFileSize:=103;
{$IFDEF DOSSETFILE1}
If (Actual = FileSize) Then Begin { No position error } If (Actual = FileSize) Then Begin { No position error }
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file } Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error } If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error }
SetFileSize := 103; { File truncate error } SetFileSize := 103; { File truncate error }
End Else SetFileSize := 103; { File truncate error } End Else SetFileSize := 103; { File truncate error }
{$ENDIF}
END; END;