mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-22 04:29:29 +02:00
* 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
This commit is contained in:
peter
parent
4496a78375
commit
eb39182b3b
421
rtl/dos/crt.pp
421
rtl/dos/crt.pp
@ -12,128 +12,108 @@
|
||||
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;
|
||||
interface
|
||||
|
||||
{$I os.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
go32;
|
||||
|
||||
const
|
||||
{ screen modes }
|
||||
bw40 = 0;
|
||||
co40 = 1;
|
||||
bw80 = 2;
|
||||
co80 = 3;
|
||||
mono = 7;
|
||||
font8x8 = 256;
|
||||
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 }
|
||||
|
||||
{ screen color, fore- and background }
|
||||
black = 0;
|
||||
blue = 1;
|
||||
green = 2;
|
||||
cyan = 3;
|
||||
red = 4;
|
||||
magenta = 5;
|
||||
brown = 6;
|
||||
lightgray = 7;
|
||||
{ Mode constants for 3.0 compatibility }
|
||||
C40 = CO40;
|
||||
C80 = CO80;
|
||||
|
||||
{ only foreground }
|
||||
darkgray = 8;
|
||||
lightblue = 9;
|
||||
lightgreen = 10;
|
||||
lightcyan = 11;
|
||||
lightred = 12;
|
||||
lightmagenta = 13;
|
||||
yellow = 14;
|
||||
white = 15;
|
||||
{ Foreground and background color constants }
|
||||
Black = 0;
|
||||
Blue = 1;
|
||||
Green = 2;
|
||||
Cyan = 3;
|
||||
Red = 4;
|
||||
Magenta = 5;
|
||||
Brown = 6;
|
||||
LightGray = 7;
|
||||
|
||||
{ blink flag }
|
||||
blink = $80;
|
||||
{ Foreground color constants }
|
||||
DarkGray = 8;
|
||||
LightBlue = 9;
|
||||
LightGreen = 10;
|
||||
LightCyan = 11;
|
||||
LightRed = 12;
|
||||
LightMagenta = 13;
|
||||
Yellow = 14;
|
||||
White = 15;
|
||||
|
||||
const
|
||||
{$ifndef GO32V2}
|
||||
directvideo:boolean=true;
|
||||
{$else GO32V2}
|
||||
{ direct video generates a GPF in DPMI of setcursor }
|
||||
directvideo:boolean=false;
|
||||
{$endif GO32V2}
|
||||
{ Add-in for blinking }
|
||||
Blink = 128;
|
||||
|
||||
var
|
||||
{ for compatibility }
|
||||
checkbreak,checkeof,checksnow : boolean;
|
||||
var
|
||||
|
||||
lastmode : word; { screen mode}
|
||||
textattr : byte; { current text attribute }
|
||||
windmin : word; { upper right corner of the CRT window }
|
||||
windmax : word; { lower left corner of the CRT window }
|
||||
{ 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 }
|
||||
|
||||
function keypressed : boolean;
|
||||
function readkey : char;
|
||||
procedure gotoxy(x,y : byte);
|
||||
procedure window(left,top,right,bottom : byte);
|
||||
procedure clrscr;
|
||||
procedure textcolor(color : byte);
|
||||
procedure textbackground(color : byte);
|
||||
procedure assigncrt(var f : text);
|
||||
function wherex : byte;
|
||||
function wherey : byte;
|
||||
procedure delline;
|
||||
procedure delline(line : byte);
|
||||
procedure clreol;
|
||||
procedure insline;
|
||||
procedure cursoron;
|
||||
procedure cursoroff;
|
||||
procedure cursorbig;
|
||||
procedure lowvideo;
|
||||
procedure highvideo;
|
||||
procedure nosound;
|
||||
procedure sound(hz : word);
|
||||
procedure delay(ms : longint);
|
||||
procedure textmode(mode : integer);
|
||||
procedure normvideo;
|
||||
|
||||
implementation
|
||||
|
||||
var
|
||||
maxcols,maxrows : longint;
|
||||
{ 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;
|
||||
|
||||
{ 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;
|
||||
|
||||
begin
|
||||
dosmemget($40,$49,getscreenmode,1);
|
||||
end;
|
||||
@ -230,6 +210,8 @@ unit crt;
|
||||
row:=0;
|
||||
dosmemget($40,$50,col,1);
|
||||
dosmemget($40,$51,row,1);
|
||||
inc(col);
|
||||
inc(row);
|
||||
end;
|
||||
|
||||
{ exported routines }
|
||||
@ -397,7 +379,7 @@ unit crt;
|
||||
|
||||
begin
|
||||
screengetcursor(row,col);
|
||||
wherex:=col-lo(windmin)+1;
|
||||
wherex:=col-lo(windmin);
|
||||
end;
|
||||
|
||||
function wherey : byte;
|
||||
@ -407,29 +389,23 @@ unit crt;
|
||||
|
||||
begin
|
||||
screengetcursor(row,col);
|
||||
wherey:=row-hi(windmin)+1;
|
||||
wherey:=row-hi(windmin);
|
||||
end;
|
||||
|
||||
procedure window(left,top,right,bottom : byte);
|
||||
|
||||
procedure Window(X1,Y1,X2,Y2: Byte);
|
||||
begin
|
||||
if (left<1) or
|
||||
(right>screencols) or
|
||||
(bottom>screenrows) or
|
||||
(left>right) or
|
||||
(top>bottom) then
|
||||
exit;
|
||||
windmin:=(left-1) or ((top-1) shl 8);
|
||||
windmax:=(right-1) or ((bottom-1) shl 8);
|
||||
if (x1<1) or (x2>screencols) or (y2>screenrows) or
|
||||
(x1>x2) or (y1>y2) then
|
||||
exit;
|
||||
windmin:=(x1-1) or ((x1-1) shl 8);
|
||||
windmax:=(x2-1) or ((y2-1) shl 8);
|
||||
gotoxy(1,1);
|
||||
end;
|
||||
|
||||
procedure clrscr;
|
||||
|
||||
var
|
||||
fil : word;
|
||||
row : longint;
|
||||
|
||||
begin
|
||||
fil:=32 or (textattr shl 8);
|
||||
for row:=hi(windmin) to hi(windmax) do
|
||||
@ -437,45 +413,41 @@ unit crt;
|
||||
gotoxy(1,1);
|
||||
end;
|
||||
|
||||
procedure textcolor(color : Byte);
|
||||
|
||||
procedure textcolor(color : Byte);
|
||||
begin
|
||||
textattr:=(textattr and $70) or color;
|
||||
end;
|
||||
|
||||
procedure lowvideo;
|
||||
|
||||
procedure lowvideo;
|
||||
begin
|
||||
textattr:=textattr and $f7;
|
||||
end;
|
||||
|
||||
procedure highvideo;
|
||||
|
||||
procedure highvideo;
|
||||
begin
|
||||
textattr:=textattr or $08;
|
||||
end;
|
||||
|
||||
procedure textbackground(color : Byte);
|
||||
|
||||
procedure textbackground(color : Byte);
|
||||
begin
|
||||
textattr:=(textattr and $8f) or ((color and $7) shl 4);
|
||||
end;
|
||||
|
||||
var
|
||||
startattrib : byte;
|
||||
|
||||
procedure normvideo;
|
||||
|
||||
begin
|
||||
textattr:=startattrib;
|
||||
end;
|
||||
|
||||
procedure delline(line : byte);
|
||||
|
||||
procedure removeline(line : byte);
|
||||
var
|
||||
row,left,right,bot : longint;
|
||||
fil : word;
|
||||
|
||||
begin
|
||||
row:=line+hi(windmin);
|
||||
left:=lo(windmin)+1;
|
||||
@ -490,10 +462,10 @@ unit crt;
|
||||
dosmemfillword($b800,get_addr(bot,left),right-left+1,fil);
|
||||
end;
|
||||
|
||||
procedure delline;
|
||||
|
||||
procedure delline;
|
||||
begin
|
||||
delline(wherey);
|
||||
removeline(wherey);
|
||||
end;
|
||||
|
||||
procedure insline;
|
||||
@ -518,11 +490,9 @@ unit crt;
|
||||
end;
|
||||
|
||||
procedure clreol;
|
||||
|
||||
var
|
||||
row,col : longint;
|
||||
fil : word;
|
||||
|
||||
begin
|
||||
screengetcursor(row,col);
|
||||
inc(row);
|
||||
@ -532,61 +502,52 @@ unit crt;
|
||||
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;
|
||||
|
||||
var
|
||||
i,col,row : longint;
|
||||
c : char;
|
||||
va,sa : word;
|
||||
|
||||
i : longint;
|
||||
begin
|
||||
screengetcursor(row,col);
|
||||
inc(row);
|
||||
inc(col);
|
||||
va:=get_addr(row,col);
|
||||
for i:=0 to f.bufpos-1 do
|
||||
begin
|
||||
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;
|
||||
WriteChar(f.buffer[i]);
|
||||
f.bufpos:=0;
|
||||
screensetcursor(row-1,col-1);
|
||||
CrtWrite:=0;
|
||||
@ -608,9 +569,7 @@ unit crt;
|
||||
|
||||
Function CrtRead(Var F: TextRec): Integer;
|
||||
Begin
|
||||
{$IFDEF GO32V2}
|
||||
f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize);
|
||||
{$ENDIF}
|
||||
f.bufpos:=0;
|
||||
CrtRead:=0;
|
||||
End;
|
||||
@ -623,18 +582,13 @@ unit crt;
|
||||
End;
|
||||
End;
|
||||
|
||||
procedure assigncrt(var f : text);
|
||||
procedure AssignCrt(var F: Text);
|
||||
begin
|
||||
TextRec(F).Mode:=fmClosed;
|
||||
TextRec(F).BufSize:=SizeOf(TextBuf);
|
||||
TextRec(F).BufPtr:=@TextRec(F).Buffer;
|
||||
TextRec(F).BufPos:=0;
|
||||
TextRec(F).OpenFunc:=@CrtOpen;
|
||||
TextRec(F).InOutFunc:=@CrtInOut;
|
||||
TextRec(F).FlushFunc:=@CrtInOut;
|
||||
TextRec(F).CloseFunc:=@CrtClose;
|
||||
TextRec(F).Name[0]:='.';
|
||||
TextRec(F).Name[1]:=#0;
|
||||
Assign(F,'.');
|
||||
TextRec(F).OpenFunc:=@CrtOpen;
|
||||
TextRec(F).InOutFunc:=@CrtInOut;
|
||||
TextRec(F).FlushFunc:=@CrtInOut;
|
||||
TextRec(F).CloseFunc:=@CrtClose;
|
||||
end;
|
||||
|
||||
procedure sound(hz : word);
|
||||
@ -648,7 +602,7 @@ unit crt;
|
||||
asm
|
||||
movzwl hz,%ecx
|
||||
movl $1193046,%eax
|
||||
cdq
|
||||
cdq
|
||||
divl %ecx
|
||||
movl %eax,%ecx
|
||||
movb $0xb6,%al
|
||||
@ -676,11 +630,9 @@ unit crt;
|
||||
var
|
||||
calibration : longint;
|
||||
|
||||
procedure delay(ms : longint);
|
||||
|
||||
procedure Delay(MS: Word);
|
||||
var
|
||||
i,j : longint;
|
||||
|
||||
begin
|
||||
for i:=1 to ms do
|
||||
for j:=1 to calibration do
|
||||
@ -695,8 +647,10 @@ unit crt;
|
||||
end;
|
||||
|
||||
procedure initdelay;
|
||||
|
||||
{ From the mailling list,
|
||||
|
||||
|
||||
{ From the mailling list,
|
||||
|
||||
by Jonathan Anderson (sarlok@geocities.com) }
|
||||
|
||||
const
|
||||
@ -739,7 +693,8 @@ unit crt;
|
||||
|
||||
if calibration<(threshold+1)*2 then
|
||||
calibration:=(threshold+1)*2;
|
||||
|
||||
|
||||
|
||||
{ If calibration is not at least this value, an }
|
||||
{ infinite loop will result. }
|
||||
|
||||
@ -788,10 +743,8 @@ unit crt;
|
||||
|
||||
|
||||
procedure textmode(mode : integer);
|
||||
|
||||
var
|
||||
set_font8x8 : boolean;
|
||||
|
||||
begin
|
||||
lastmode:=mode;
|
||||
set_font8x8:=(mode and font8x8)<>0;
|
||||
@ -803,8 +756,6 @@ unit crt;
|
||||
maxrows:=screenrows;
|
||||
end;
|
||||
|
||||
var
|
||||
col,row : longint;
|
||||
|
||||
begin
|
||||
is_last:=false;
|
||||
@ -824,11 +775,9 @@ begin
|
||||
|
||||
{ redirect the standard output }
|
||||
assigncrt(Output);
|
||||
TextRec(Output).mode:=fmOutput;
|
||||
{$IFDEF GO32V2}
|
||||
assigncrt(Input);
|
||||
TextRec(Output).mode:=fmOutput;
|
||||
TextRec(Input).mode:=fmInput;
|
||||
{$ENDIF GO32V2}
|
||||
|
||||
{ calculates delay calibration }
|
||||
initdelay;
|
||||
@ -836,56 +785,12 @@ end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 1998-03-25 11:18:41 root
|
||||
Initial revision
|
||||
Revision 1.2 1998-05-21 19:30:46 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.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
978
rtl/dos/dos.pp
File diff suppressed because it is too large
Load Diff
@ -29,7 +29,7 @@ unit emu387;
|
||||
|
||||
implementation
|
||||
|
||||
uses dxeload, dpmiexcp, strings;
|
||||
uses dxeload, dpmiexcp;
|
||||
|
||||
type
|
||||
emu_entry_type = function(exc : pexception_state) : longint;
|
||||
@ -123,10 +123,10 @@ unit emu387;
|
||||
hp : ppchar;
|
||||
hs,
|
||||
_envvar : string;
|
||||
eqpos,i : longint;
|
||||
eqpos : longint;
|
||||
begin
|
||||
_envvar:=upcase(envvar);
|
||||
hp:=environ;
|
||||
hp:=envp;
|
||||
getenv:='';
|
||||
while assigned(hp^) do
|
||||
begin
|
||||
@ -147,7 +147,7 @@ unit emu387;
|
||||
cp : string;
|
||||
i : byte;
|
||||
have_80387 : boolean;
|
||||
emu_p : pointer;
|
||||
emu_p : pointer;
|
||||
const
|
||||
veryfirst : boolean = True;
|
||||
|
||||
@ -217,7 +217,13 @@ end.
|
||||
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.2 1998/03/26 12:23:17 peter
|
||||
@ -254,7 +260,13 @@ end.
|
||||
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.2 1998/03/26 12:23:17 peter
|
||||
|
||||
@ -17,33 +17,46 @@ unit system;
|
||||
|
||||
{$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
|
||||
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;
|
||||
{$I heaph.inc}
|
||||
|
||||
const
|
||||
UnusedHandle=$ffff;
|
||||
StdInputHandle=0;
|
||||
StdOutputHandle=1;
|
||||
StdErrorHandle=2;
|
||||
{ Default filehandles }
|
||||
UnusedHandle = $ffff;
|
||||
StdInputHandle = 0;
|
||||
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
|
||||
t_stub_info = record
|
||||
{ Dos Extender info }
|
||||
p_stub_info = ^t_stub_info;
|
||||
t_stub_info = packed record
|
||||
magic : array[0..15] of char;
|
||||
size : longint;
|
||||
minstack : longint;
|
||||
@ -58,146 +71,125 @@ type
|
||||
basename : array[0..7] of char;
|
||||
argv0 : array [0..15] of char;
|
||||
dpmi_server : array [0..15] of char;
|
||||
end;
|
||||
p_stub_info = ^t_stub_info;
|
||||
end;
|
||||
|
||||
var stub_info : p_stub_info;
|
||||
|
||||
{$PACKRECORDS 1}
|
||||
type
|
||||
t_go32_info_block = record
|
||||
size_of_this_structure_in_bytes : longint; {offset 0}
|
||||
linear_address_of_primary_screen : longint; {offset 4}
|
||||
p_go32_info_block = ^t_go32_info_block;
|
||||
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_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;
|
||||
linear_address_of_original_psp : longint; {offset 32}
|
||||
run_mode : word; {offset 36}
|
||||
run_mode_info : word; {offset 38}
|
||||
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;
|
||||
procedure syscopyfromdos(addr : longint; len : longint);
|
||||
procedure syscopytodos(addr : longint; len : longint);
|
||||
function tb : longint;
|
||||
procedure sysrealintr(intnr : word;var regs : trealregs);
|
||||
{
|
||||
necessary for objects.pas, should be removed (at least from the interface
|
||||
to the implementation)
|
||||
}
|
||||
type
|
||||
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
|
||||
plongint = ^longint;
|
||||
{ include system independent routines }
|
||||
|
||||
const carryflag = 1;
|
||||
{$I system.inc}
|
||||
|
||||
{$S-}
|
||||
procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
|
||||
const
|
||||
carryflag = 1;
|
||||
|
||||
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 !! }
|
||||
type
|
||||
plongint = ^longint;
|
||||
|
||||
asm
|
||||
pushl %eax
|
||||
pushl %ebx
|
||||
movl stack_size,%ebx
|
||||
movl %esp,%eax
|
||||
subl %ebx,%eax
|
||||
var
|
||||
doscmd : string[128]; { Dos commandline copied from PSP, max is 128 chars }
|
||||
|
||||
|
||||
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
|
||||
{
|
||||
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}
|
||||
movl U_SYSTEM_LOWESTSTACK,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jb _is_not_lowest
|
||||
movl %eax,U_SYSTEM_LOWESTSTACK
|
||||
_is_not_lowest:
|
||||
movl U_SYSTEM_LOWESTSTACK,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jb _is_not_lowest
|
||||
movl %eax,U_SYSTEM_LOWESTSTACK
|
||||
_is_not_lowest:
|
||||
{$endif SYSTEMDEBUG}
|
||||
movl __stkbottom,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jae __short_on_stack
|
||||
popl %ebx
|
||||
popl %eax
|
||||
leave
|
||||
ret $4
|
||||
__short_on_stack:
|
||||
{ can be usefull for error recovery !! }
|
||||
popl %ebx
|
||||
popl %eax
|
||||
end['EAX','EBX'];
|
||||
RunError(202);
|
||||
{ this needs a local variable }
|
||||
{ so the function called itself !! }
|
||||
{ Writeln('low in stack ');
|
||||
RunError(202); }
|
||||
end;
|
||||
movl __stkbottom,%ebx
|
||||
cmpl %eax,%ebx
|
||||
jae __short_on_stack
|
||||
popl %ebx
|
||||
popl %eax
|
||||
leave
|
||||
ret $4
|
||||
__short_on_stack:
|
||||
{ can be usefull for error recovery !! }
|
||||
popl %ebx
|
||||
popl %eax
|
||||
end['EAX','EBX'];
|
||||
RunError(202);
|
||||
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;
|
||||
begin
|
||||
tb_size := go32_info_block.size_of_transfer_buffer;
|
||||
{ asm
|
||||
leal __go32_info_block,%ebx
|
||||
movl 16(%ebx),%eax
|
||||
leave
|
||||
ret
|
||||
end ['EAX','EBX'];}
|
||||
end;
|
||||
function tb : longint;
|
||||
begin
|
||||
tb:=go32_info_block.linear_address_of_transfer_buffer;
|
||||
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
|
||||
movw %ds,%ax
|
||||
movw %ax,__RESULT;
|
||||
end;
|
||||
end;
|
||||
|
||||
function dos_selector : word;
|
||||
begin
|
||||
dos_selector:=go32_info_block.selector_for_linear_memory;
|
||||
end;
|
||||
|
||||
|
||||
function get_ds : word;assembler;
|
||||
asm
|
||||
movw %ds,%ax
|
||||
end;
|
||||
|
||||
|
||||
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;
|
||||
|
||||
|
||||
{ included directly old file sargs.inc }
|
||||
|
||||
var argc : longint;
|
||||
doscmd : string;
|
||||
args : ppchar;
|
||||
|
||||
function far_strlen(selector : word;linear_address : longint) : longint;
|
||||
begin
|
||||
asm
|
||||
@ -294,6 +279,7 @@ asm
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function atohex(s : pchar) : longint;
|
||||
var rv : longint;
|
||||
v : byte;
|
||||
@ -316,7 +302,7 @@ var psp : word;
|
||||
i,j : byte;
|
||||
quote : char;
|
||||
proxy_s : string[7];
|
||||
tempargs : ppchar;
|
||||
tempargv : ppchar;
|
||||
al,proxy_argc,proxy_seg,proxy_ofs,lin : longint;
|
||||
largs : array[0..127] of pchar;
|
||||
rm_argv : ^arrayword;
|
||||
@ -394,16 +380,17 @@ if (argc > 1) and (far_strlen(get_ds,longint(largs[1])) = 6) then
|
||||
argc := proxy_argc;
|
||||
end;
|
||||
end;
|
||||
getmem(args,argc*SizeOf(pchar));
|
||||
getmem(argv,argc shl 2);
|
||||
for i := 0 to argc-1 do
|
||||
args[i] := largs[i];
|
||||
tempargs:=args;
|
||||
argv[i] := largs[i];
|
||||
tempargv:=argv;
|
||||
asm
|
||||
movl tempargs,%eax
|
||||
movl tempargv,%eax
|
||||
movl %eax,_args
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function strcopy(dest,source : pchar) : pchar;
|
||||
|
||||
begin
|
||||
@ -454,36 +441,37 @@ begin
|
||||
while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
|
||||
inc(longint(cp)); { skip to next character }
|
||||
end;
|
||||
getmem(environ,(env_count+1) * sizeof(pchar));
|
||||
if (environ = nil) then exit;
|
||||
getmem(envp,(env_count+1) * sizeof(pchar));
|
||||
if (envp = nil) then exit;
|
||||
cp:=dos_env;
|
||||
env_count:=0;
|
||||
while cp^ <> #0 do
|
||||
begin
|
||||
getmem(environ[env_count],strlen(cp)+1);
|
||||
strcopy(environ[env_count], cp);
|
||||
getmem(envp[env_count],strlen(cp)+1);
|
||||
strcopy(envp[env_count], cp);
|
||||
{$IfDef SYSTEMDEBUG}
|
||||
Writeln('env ',env_count,' = "',environ[env_count],'"');
|
||||
Writeln('env ',env_count,' = "',envp[env_count],'"');
|
||||
{$EndIf SYSTEMDEBUG}
|
||||
inc(env_count);
|
||||
while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
|
||||
inc(longint(cp)); { skip to next character }
|
||||
end;
|
||||
environ[env_count]:=nil;
|
||||
envp[env_count]:=nil;
|
||||
inc(longint(cp),3);
|
||||
getmem(dos_argv0,strlen(cp)+1);
|
||||
if (dos_argv0 = nil) then halt;
|
||||
strcopy(dos_argv0, cp);
|
||||
end;
|
||||
|
||||
procedure syscopytodos(addr : longint; len : longint);
|
||||
begin
|
||||
if len > tb_size then runerror(200);
|
||||
if len > tb_size then runerror(217);
|
||||
sysseg_move(get_ds,addr,dos_selector,tb,len);
|
||||
end;
|
||||
|
||||
procedure syscopyfromdos(addr : longint; len : longint);
|
||||
begin
|
||||
if len > tb_size then runerror(200);
|
||||
if len > tb_size then runerror(217);
|
||||
sysseg_move(dos_selector,tb,get_ds,addr,len);
|
||||
end;
|
||||
|
||||
@ -496,8 +484,6 @@ end;
|
||||
movw intnr,%bx
|
||||
xorl %ecx,%ecx
|
||||
movl regs,%edi
|
||||
|
||||
// es is always equal ds
|
||||
movw $0x300,%ax
|
||||
int $0x31
|
||||
end;
|
||||
@ -519,60 +505,47 @@ 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
|
||||
if (l>=0) and (l<=paramcount) then
|
||||
begin
|
||||
p:=args;
|
||||
paramstr:=strpas(p[l]);
|
||||
end
|
||||
else paramstr:='';
|
||||
end;
|
||||
procedure randomize;
|
||||
var
|
||||
hl : longint;
|
||||
regs : trealregs;
|
||||
begin
|
||||
regs.realeax:=$2c00;
|
||||
sysrealintr($21,regs);
|
||||
hl:=regs.realedx and $ffff;
|
||||
randseed:=hl*$10000+ (regs.realecx and $ffff);
|
||||
end;
|
||||
|
||||
procedure randomize;
|
||||
{*****************************************************************************
|
||||
Heap Management
|
||||
*****************************************************************************}
|
||||
|
||||
var
|
||||
hl : longint;
|
||||
regs : trealregs;
|
||||
function Sbrk(size : longint):longint;assembler;
|
||||
asm
|
||||
movl size,%eax
|
||||
pushl %eax
|
||||
call ___sbrk
|
||||
addl $4,%esp
|
||||
end;
|
||||
|
||||
begin
|
||||
regs.realeax:=$2c00;
|
||||
sysrealintr($21,regs);
|
||||
hl:=regs.realedx and $ffff;
|
||||
randseed:=hl*$10000+ (regs.realecx and $ffff);
|
||||
end;
|
||||
{ include standard heap management }
|
||||
{$I heap.inc}
|
||||
|
||||
{ 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
|
||||
@ -768,7 +741,6 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function do_filesize(handle : longint) : longint;
|
||||
var
|
||||
aktfilepos : longint;
|
||||
@ -960,7 +932,7 @@ begin
|
||||
end
|
||||
else
|
||||
syscopyfromdos(longint(@temp),251);
|
||||
{ conversation to Pascal string }
|
||||
{ conversation to Pascal string including slash conversion }
|
||||
i:=0;
|
||||
while (temp[i]<>#0) do
|
||||
begin
|
||||
@ -972,7 +944,7 @@ begin
|
||||
dir[2]:=':';
|
||||
dir[3]:='\';
|
||||
dir[0]:=chr(i+3);
|
||||
{ upcase the string (FPKPascal function) }
|
||||
{ upcase the string }
|
||||
dir:=upcase(dir);
|
||||
if drivenr<>0 then { Drive was supplied. We know it }
|
||||
dir[1]:=chr(65+drivenr-1)
|
||||
@ -999,7 +971,7 @@ begin
|
||||
regs.realeax:=$160a;
|
||||
sysrealintr($2f,regs);
|
||||
CheckWin95:=(regs.realeax=0) and ((regs.realebx and $ff00)=$400);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure OpenStdIO(var f:text;mode:word;hdl:longint);
|
||||
@ -1012,7 +984,7 @@ begin
|
||||
TextRec(f).Closefunc:=@fileclosefunc;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Begin
|
||||
{ Initialize ExitProc }
|
||||
ExitProc:=Nil;
|
||||
@ -1029,12 +1001,18 @@ Begin
|
||||
Setup_Arguments;
|
||||
{ Use Win95 LFN }
|
||||
Win95:=CheckWin95;
|
||||
{ Reset IO Error }
|
||||
{ Reset IO Error }
|
||||
InOutRes:=0;
|
||||
End.
|
||||
{
|
||||
$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
|
||||
|
||||
Revision 1.3 1998/05/04 16:21:54 florian
|
||||
|
||||
@ -31,6 +31,24 @@ Begin
|
||||
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];
|
||||
{
|
||||
Create file f with recordsize of l
|
||||
@ -242,22 +260,44 @@ Begin
|
||||
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];
|
||||
var
|
||||
p : array[0..255] Of Char;
|
||||
Begin
|
||||
If FileRec(f).mode=fmClosed Then
|
||||
Begin
|
||||
Move(s[1],p,Length(s));
|
||||
p[Length(s)]:=#0;
|
||||
Do_Rename(PChar(@FileRec(f).Name),PChar(@p));
|
||||
Move(p,FileRec(f).Name,Length(s)+1);
|
||||
End;
|
||||
Move(s[1],p,Length(s));
|
||||
p[Length(s)]:=#0;
|
||||
Rename(f,Pchar(@p));
|
||||
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;
|
||||
|
||||
{
|
||||
$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
|
||||
+ strpas, strlen are now exported in the systemunit
|
||||
* removed logs
|
||||
|
||||
@ -6,7 +6,6 @@
|
||||
|
||||
Getopt implementation for Free Pascal, modeled after GNU getopt.
|
||||
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
@ -17,8 +16,6 @@
|
||||
**********************************************************************}
|
||||
unit getopts;
|
||||
|
||||
{$I os.inc}
|
||||
|
||||
{ --------------------------------------------------------------------
|
||||
*NOTE*
|
||||
The routines are a more or less straightforward conversion
|
||||
@ -33,16 +30,14 @@ Interface
|
||||
Const No_Argument = 0;
|
||||
Required_Argument = 1;
|
||||
Optional_Argument = 2;
|
||||
|
||||
EndOfOptions = #255;
|
||||
|
||||
|
||||
Type TOption = Record
|
||||
Name : String;
|
||||
Has_arg : Integer;
|
||||
Flag : PChar;
|
||||
Value : Char;
|
||||
end;
|
||||
end;
|
||||
POption = ^TOption;
|
||||
Orderings = (require_order,permute,return_in_order);
|
||||
|
||||
@ -51,13 +46,8 @@ Var OptArg : String;
|
||||
OptErr : Boolean;
|
||||
OptOpt : Char;
|
||||
|
||||
|
||||
Function GetOpt (ShortOpts : String) : char;
|
||||
Function GetLongOpts (ShortOpts : String;
|
||||
|
||||
LongOpts : POption;
|
||||
|
||||
var Longind : Integer) : char;
|
||||
Function GetLongOpts (ShortOpts : String;LongOpts : POption;var Longind : Integer) : char;
|
||||
|
||||
Implementation
|
||||
|
||||
@ -68,8 +58,6 @@ Var
|
||||
last_nonopt : Longint;
|
||||
Ordering : Orderings;
|
||||
|
||||
|
||||
|
||||
Procedure Exchange;
|
||||
var
|
||||
bottom,
|
||||
@ -120,28 +108,26 @@ begin
|
||||
OptOpt:='?';
|
||||
Nextchar:=0;
|
||||
if opts[1]='-' then
|
||||
|
||||
begin
|
||||
ordering:=return_in_order;
|
||||
delete(opts,1,1);
|
||||
end
|
||||
else
|
||||
if opts[1]='+' then
|
||||
begin
|
||||
ordering:=return_in_order;
|
||||
delete(opts,1,1);
|
||||
ordering:=require_order;
|
||||
delete(opts,1,1);
|
||||
end
|
||||
else if opts[1]='+' then
|
||||
begin
|
||||
ordering:=require_order;
|
||||
delete(opts,1,1);
|
||||
end
|
||||
else ordering:=permute;
|
||||
else
|
||||
ordering:=permute;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
Function Internal_getopt (Var Optstring : string;
|
||||
LongOpts : POption;
|
||||
LongInd : pointer;
|
||||
Long_only : boolean ) : char;
|
||||
Function Internal_getopt (Var Optstring : string;LongOpts : POption;
|
||||
LongInd : pointer;Long_only : boolean ) : char;
|
||||
type
|
||||
pinteger=^integer;
|
||||
|
||||
var
|
||||
temp,endopt,option_index : byte;
|
||||
indfound: integer;
|
||||
@ -149,7 +135,6 @@ var
|
||||
p,pfound : POption;
|
||||
exact,ambig : boolean;
|
||||
c : char;
|
||||
|
||||
begin
|
||||
optarg:='';
|
||||
if optind=0 then
|
||||
@ -157,7 +142,6 @@ begin
|
||||
{ Check if We need the next argument. }
|
||||
if optind<nrargs then currentarg:=strpas(argv[optind]) else currentarg:='';
|
||||
if (nextchar=0) then
|
||||
|
||||
begin
|
||||
if ordering=permute then
|
||||
begin
|
||||
@ -183,13 +167,11 @@ begin
|
||||
if (first_nonopt<>last_nonopt) and (last_nonopt<>optind) then
|
||||
exchange
|
||||
else
|
||||
|
||||
if first_nonopt=last_nonopt then
|
||||
first_nonopt:=optind;
|
||||
last_nonopt:=nrargs;
|
||||
optind:=nrargs;
|
||||
end;
|
||||
|
||||
{ Are we at the end of all arguments ? }
|
||||
if optind>=nrargs then
|
||||
begin
|
||||
@ -226,7 +208,6 @@ begin
|
||||
end;
|
||||
{ Check if we have a long option }
|
||||
if longopts<>nil then
|
||||
|
||||
if length(currentarg)>1 then
|
||||
if (currentarg[2]='-') or
|
||||
((not long_only) and (pos(currentarg[2],optstring)<>0)) then
|
||||
@ -266,7 +247,6 @@ begin
|
||||
inc (option_index);
|
||||
end;
|
||||
if ambig and not exact then
|
||||
|
||||
begin
|
||||
if opterr then
|
||||
writeln (paramstr(0),': option "',optname,'" is ambiguous');
|
||||
@ -287,16 +267,13 @@ begin
|
||||
if currentarg[2]='-' then
|
||||
writeln (paramstr(0),': option "--',pfound^.name,'" doesn''t allow an argument')
|
||||
else
|
||||
|
||||
writeln (paramstr(0),': option "',currentarg[1],pfound^.name,'" doesn''t allow an argument');
|
||||
nextchar:=0;
|
||||
internal_getopt:='?';
|
||||
exit;
|
||||
end;
|
||||
end
|
||||
|
||||
else { argument in next paramstr... }
|
||||
|
||||
begin
|
||||
if pfound^.has_arg=1 then
|
||||
begin
|
||||
@ -317,13 +294,11 @@ begin
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
end; { argument in next parameter end;}
|
||||
nextchar:=0;
|
||||
if longind<>nil then
|
||||
pinteger(longind)^:=indfound+1;
|
||||
if pfound^.flag<>nil then
|
||||
|
||||
begin
|
||||
pfound^.flag^:=pfound^.value;
|
||||
internal_getopt:=#0;
|
||||
@ -346,14 +321,12 @@ begin
|
||||
Internal_getopt:='?';
|
||||
exit;
|
||||
end;
|
||||
|
||||
end; { Of long options.}
|
||||
{ We check for a short option. }
|
||||
temp:=pos(currentarg[nextchar],optstring);
|
||||
c:=currentarg[nextchar];
|
||||
inc(nextchar);
|
||||
if nextchar>length(currentarg) then
|
||||
|
||||
begin
|
||||
inc(optind);
|
||||
nextchar:=0;
|
||||
@ -368,7 +341,6 @@ begin
|
||||
end;
|
||||
Internal_getopt:=optstring[temp];
|
||||
if optstring[temp+1]=':' then
|
||||
|
||||
if currentarg[temp+2]=':' then
|
||||
begin { optional argument }
|
||||
optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1);
|
||||
@ -377,7 +349,6 @@ begin
|
||||
else
|
||||
begin { required argument }
|
||||
if nextchar>0 then
|
||||
|
||||
begin
|
||||
optarg:=copy (currentarg,nextchar,length(currentarg)-nextchar+1);
|
||||
inc(optind)
|
||||
@ -389,11 +360,9 @@ begin
|
||||
writeln (paramstr(0),': option requires an argument -- ',optstring[temp]);
|
||||
optopt:=optstring[temp];
|
||||
if optstring[1]=':' then
|
||||
|
||||
Internal_getopt:=':'
|
||||
else
|
||||
Internal_Getopt:='?'
|
||||
|
||||
end
|
||||
else
|
||||
begin
|
||||
@ -411,31 +380,28 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
Function GetLongOpts(ShortOpts : String;
|
||||
|
||||
LongOpts : POption;
|
||||
|
||||
var Longind : Integer) : char;
|
||||
Function GetLongOpts (ShortOpts : String;LongOpts : POption;var Longind : Integer) : char;
|
||||
begin
|
||||
getlongopts:=internal_getopt ( shortopts,longopts,@longind,true);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
begin
|
||||
{ Needed to detect startup }
|
||||
|
||||
Opterr:=true;
|
||||
Optind:=0;
|
||||
nrargs:=paramcount+1;
|
||||
end.
|
||||
|
||||
|
||||
|
||||
{
|
||||
$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
|
||||
+ strpas, strlen are now exported in the systemunit
|
||||
* removed logs
|
||||
|
||||
@ -1,3 +1,6 @@
|
||||
{
|
||||
$Id$
|
||||
}
|
||||
{************[ SOURCE FILE OF FREE VISION ]****************}
|
||||
{ }
|
||||
{ System independent clone of objects.pas }
|
||||
@ -85,16 +88,20 @@ UNIT Objects;
|
||||
|
||||
|
||||
{==== 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 }
|
||||
{$X+} { Extended syntax is ok }
|
||||
{$F+} { Force far calls }
|
||||
{$A+} { Word Align Data }
|
||||
{$R-} { Disable range checking }
|
||||
{$S-} { Disable Stack Checking }
|
||||
{$I-} { Disable IO Checking }
|
||||
{$Q-} { Disable Overflow Checking }
|
||||
{$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 }
|
||||
{---------------------------------------------------------------------------}
|
||||
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
|
||||
If (ALimit <> BlkCount) Then Begin { Change is needed }
|
||||
ChangeListSize := False; { Preset failure }
|
||||
@ -1946,7 +1953,7 @@ END;
|
||||
{---------------------------------------------------------------------------}
|
||||
PROCEDURE TCollection.Store (Var S: TStream);
|
||||
|
||||
PROCEDURE DoPutItem (P: Pointer); FAR;
|
||||
PROCEDURE DoPutItem (P: Pointer);{$IFNDEF FPC}FAR;{$ENDIF}
|
||||
BEGIN
|
||||
PutItem(S, P); { Put item on stream }
|
||||
END;
|
||||
@ -2018,6 +2025,7 @@ END;
|
||||
FUNCTION TSortedCollection.Compare (Key1, Key2: Pointer): Sw_Integer;
|
||||
BEGIN
|
||||
Abstract; { Abstract method }
|
||||
Compare:=0;
|
||||
END;
|
||||
|
||||
{--TSortedCollection--------------------------------------------------------}
|
||||
@ -2409,7 +2417,7 @@ END;
|
||||
FUNCTION TResourceFile.SwitchTo (AStream: PStream; Pack: Boolean): PStream;
|
||||
VAR NewBasePos: LongInt;
|
||||
|
||||
PROCEDURE DoCopyResource (Item: PResourceItem); FAR;
|
||||
PROCEDURE DoCopyResource (Item: PResourceItem);{$IFNDEF FPC}FAR;{$ENDIF}
|
||||
BEGIN
|
||||
Stream^.Seek(BasePos + Item^.Posn); { Move stream position }
|
||||
Item^.Posn := AStream^.GetPos - NewBasePos; { Hold new position }
|
||||
@ -2719,3 +2727,12 @@ 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
|
||||
|
||||
}
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{*****************************************************************************
|
||||
$Id$
|
||||
Include file to sort out compilers/platforms/targets
|
||||
|
||||
Copyright (c) 1997 Balazs Scheidler (bazsi@tas.vein.hu)
|
||||
@ -8,7 +9,6 @@
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
|
||||
This library is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
@ -120,3 +120,12 @@
|
||||
Requires Free Pascal (FPK) v0.9.2 or higher
|
||||
{$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
|
||||
|
||||
}
|
||||
|
||||
@ -32,7 +32,8 @@ Type
|
||||
shortint = -128..127;
|
||||
byte = 0..255;
|
||||
Word = 0..65535;
|
||||
|
||||
|
||||
|
||||
{ at least declare Turbo Pascal real types }
|
||||
{$IFDEF i386}
|
||||
Double = real;
|
||||
@ -53,7 +54,8 @@ const
|
||||
{ max. values for longint and int}
|
||||
maxLongint = $7fffffff;
|
||||
maxint = 32767;
|
||||
|
||||
|
||||
|
||||
{ Compatibility With TP }
|
||||
{$ifdef i386}
|
||||
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;p:pchar);
|
||||
Procedure Assign(Var f:File;c:char);
|
||||
Procedure Rewrite(Var f:File;l:Word);
|
||||
Procedure Rewrite(Var f:File);
|
||||
Procedure Reset(Var f:File;l:Word);
|
||||
@ -255,6 +259,8 @@ Procedure Seek(Var f:File;Pos:Longint);
|
||||
Function EOF(Var f:File):Boolean;
|
||||
Procedure Erase(Var f:File);
|
||||
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);
|
||||
|
||||
{****************************************************************************
|
||||
@ -262,6 +268,8 @@ Procedure Truncate (Var F:File);
|
||||
****************************************************************************}
|
||||
|
||||
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 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;p:pchar);
|
||||
Procedure Assign(Var t:Text;c:char);
|
||||
Procedure Close(Var t:Text);
|
||||
Procedure Rewrite(Var t:Text);
|
||||
Procedure Reset(Var t:Text);
|
||||
@ -277,6 +287,8 @@ Procedure Append(Var t:Text);
|
||||
Procedure Flush(Var t:Text);
|
||||
Procedure Erase(Var t:Text);
|
||||
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:Boolean;
|
||||
Function EOLn(Var t:Text):Boolean;
|
||||
@ -320,7 +332,13 @@ Procedure AddExitProc(Proc:TProcedure);
|
||||
|
||||
{
|
||||
$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
|
||||
+ strpas, strlen are now exported in the systemunit
|
||||
* removed logs
|
||||
|
||||
@ -77,6 +77,18 @@ Begin
|
||||
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];
|
||||
Begin
|
||||
If (TextRec(t).mode<>fmClosed) Then
|
||||
@ -149,20 +161,36 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
Procedure Rename(var t:Text;const s:String);[IOCheck];
|
||||
var
|
||||
p : array[0..255] Of Char;
|
||||
Procedure Rename(var t : text;p:pchar);[IOCheck];
|
||||
Begin
|
||||
If TextRec(t).mode=fmClosed Then
|
||||
Begin
|
||||
Move(s[1],p,Length(s));
|
||||
p[Length(s)]:=#0;
|
||||
Do_Rename(PChar(@TextRec(t).Name),PChar(@p));
|
||||
Move(p,TextRec(t).Name,Length(s)+1);
|
||||
Do_Rename(PChar(@TextRec(t).Name),p);
|
||||
Move(p,TextRec(t).Name,StrLen(p)+1);
|
||||
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];
|
||||
Begin
|
||||
{$IFNDEF EXTENDED_EOF}
|
||||
@ -678,8 +706,41 @@ Begin
|
||||
{ copy string. }
|
||||
Move (f.Bufptr^[f.BufPos],p^,Temp-f.BufPos);
|
||||
Inc(Longint(p),Temp-f.BufPos);
|
||||
If p^=#13 Then
|
||||
dec(Longint(p));
|
||||
If pchar(p-1)^=#13 Then
|
||||
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 }
|
||||
f.BufPos:=Temp;
|
||||
If Temp>=f.BufEnd Then
|
||||
@ -887,7 +948,13 @@ Begin
|
||||
End;
|
||||
{
|
||||
$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
|
||||
+ strpas, strlen are now exported in the systemunit
|
||||
* removed logs
|
||||
|
||||
@ -17,6 +17,9 @@
|
||||
****************************************************************************}
|
||||
|
||||
Procedure assign(var f:TypedFile;const Name:string);
|
||||
{
|
||||
Assign Name to file f so it can be used with the file routines
|
||||
}
|
||||
Begin
|
||||
FillChar(f,SizeOF(FileRec),0);
|
||||
FileRec(f).Handle:=UnusedHandle;
|
||||
@ -25,6 +28,24 @@ Begin
|
||||
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'];
|
||||
Begin
|
||||
Reset(UnTypedFile(f),Size);
|
||||
@ -54,7 +75,13 @@ End;
|
||||
|
||||
{
|
||||
$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
|
||||
+ strpas, strlen are now exported in the systemunit
|
||||
* removed logs
|
||||
|
||||
@ -232,8 +232,10 @@ crt$(PPUEXT) : crt.pp $(INC)/textrec.inc $(INC)/filerec.inc linux$(PPUEXT)\
|
||||
$(SYSTEMPPU)
|
||||
$(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)
|
||||
$(DEL) objects.pp
|
||||
|
||||
printer$(PPUEXT) : printer.pp $(INC)/textrec.inc linux$(PPUEXT) $(SYSTEMPPU)
|
||||
$(PP) $(OPT) printer $(REDIR)
|
||||
|
||||
@ -56,12 +56,20 @@ BEGIN
|
||||
END;
|
||||
|
||||
FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word;
|
||||
{$IFDEF DOSSETFILE1}
|
||||
VAR Actual, Buf: LongInt;
|
||||
{$ENDIF}
|
||||
BEGIN
|
||||
if Sys_Truncate(Handle,FileSize)=0 then
|
||||
SetFileSize:=0
|
||||
else
|
||||
SetFileSize:=103;
|
||||
{$IFDEF DOSSETFILE1}
|
||||
If (Actual = FileSize) Then Begin { No position error }
|
||||
Actual := FileWrite(Handle, Pointer(@Buf), 0,Actual); { Truncate the file }
|
||||
If (Actual <> -1) Then SetFileSize := 0 Else { No truncate error }
|
||||
SetFileSize := 103; { File truncate error }
|
||||
End Else SetFileSize := 103; { File truncate error }
|
||||
{$ENDIF}
|
||||
END;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user