OS_Develop/dos_compilers
OS_Develop/dos_compilers
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Borland Turbo Pascal v5.5

Browse Source
This commit is contained in:
davidly 2024-07-02 06:49:04 -07:00
parent d64f7de3f9
commit cef8f335d0
170 changed files with 24945 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

383
Borland Turbo Pascal v55/ARTY.PAS Normal file
View File

@ -0,0 +1,383 @@
{ Turbo Art }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program Arty;
{ This program is a demonstration of the Borland Graphics Interface
(BGI) provided with Turbo Pascal 5.5.
To run this program you will need the following files:
TURBO.EXE (or TPC.EXE)
TURBO.TPL - The standard units
GRAPH.TPU - The Graphics unit
*.BGI - The graphics device drivers
Runtime Commands for ARTY
-------------------------
<B> - changes background color
<C> - changes drawcolor
<ESC> - exits program
Any other key pauses, then regenerates the drawing
Note: If a /H command-line parameter is specified, the highest
resolution mode will be used (if possible).
}
uses
Crt, Graph;
const
Memory = 100;
Windows = 4;
type
ResolutionPreference = (Lower, Higher);
ColorList = array [1..Windows] of integer;
var
Xmax,
Ymax,
ViewXmax,
ViewYmax : integer;
Line: array [1..Memory] of record
LX1,LY1: integer;
LX2,LY2: integer;
LColor : ColorList;
end;
X1,X2,Y1,Y2,
CurrentLine,
ColorCount,
IncrementCount,
DeltaX1,DeltaY1,DeltaX2,DeltaY2: integer;
Colors: ColorList;
Ch: char;
BackColor:integer;
GraphDriver, GraphMode : integer;
MaxColors : word;
MaxDelta : integer;
ChangeColors: Boolean;
procedure Frame;
begin
SetViewPort(0, 0, Xmax, Ymax-(TextHeight('M')+4)-1,ClipOn);
SetColor(MaxColors);
Rectangle(0, 0, Xmax-1, (Ymax-(TextHeight('M')+4)-1)-1);
SetViewPort(1, 1, Xmax-2, (Ymax-(TextHeight('M')+4)-1)-2,ClipOn);
end { Frame };
procedure FullPort;
{ Set the view port to the entire screen }
begin
SetViewPort(0, 0, Xmax, Ymax, ClipOn);
end; { FullPort }
procedure MessageFrame(Msg:string);
begin
FullPort;
SetColor(MaxColors);
SetTextStyle(DefaultFont, HorizDir, 1);
SetTextJustify(CenterText, TopText);
SetLineStyle(SolidLn, 0, NormWidth);
SetFillStyle(EmptyFill, 0);
Bar(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
Rectangle(0, Ymax-(TextHeight('M')+4), Xmax, Ymax);
OutTextXY(Xmax div 2, Ymax-(TextHeight('M')+2), Msg);
{ Go back to the main window }
Frame;
end { MessageFrame };
procedure WaitToGo;
var
Ch : char;
begin
MessageFrame('Press any key to continue... Esc aborts');
repeat until KeyPressed;
Ch := ReadKey;
if Ch = #27 then begin
CloseGraph;
Writeln('All done.');
Halt(1);
end
else
ClearViewPort;
MessageFrame('Press a key to stop action, Esc quits.');
end; { WaitToGo }
procedure TestGraphError(GraphErr: integer);
begin
if GraphErr <> grOk then begin
Writeln('Graphics error: ', GraphErrorMsg(GraphErr));
repeat until keypressed;
ch := readkey;
Halt(1);
end;
end;
procedure Init;
var
Err, I: integer;
StartX, StartY: integer;
Resolution: ResolutionPreference;
s: string;
begin
Resolution := Lower;
if paramcount > 0 then begin
s := paramstr(1);
if s[1] = '/' then
if upcase(s[2]) = 'H' then
Resolution := Higher;
end;
CurrentLine := 1;
ColorCount := 0;
IncrementCount := 0;
Ch := ' ';
GraphDriver := Detect;
DetectGraph(GraphDriver, GraphMode);
TestGraphError(GraphResult);
case GraphDriver of
CGA : begin
MaxDelta := 7;
GraphDriver := CGA;
GraphMode := CGAC1;
end;
MCGA : begin
MaxDelta := 7;
case GraphMode of
MCGAMed, MCGAHi: GraphMode := MCGAC1;
end;
end;
EGA : begin
MaxDelta := 16;
If Resolution = Lower then
GraphMode := EGALo
else
GraphMode := EGAHi;
end;
EGA64 : begin
MaxDelta := 16;
If Resolution = Lower then
GraphMode := EGA64Lo
else
GraphMode := EGA64Hi;
end;
HercMono : MaxDelta := 16;
EGAMono : MaxDelta := 16;
PC3270 : begin
MaxDelta := 7;
GraphDriver := CGA;
GraphMode := CGAC1;
end;
ATT400 : case GraphMode of
ATT400C1,
ATT400C2,
ATT400Med,
ATT400Hi :
begin
MaxDelta := 7;
GraphMode := ATT400C1;
end;
end;
VGA : begin
MaxDelta := 16;
end;
end;
InitGraph(GraphDriver, GraphMode, '');
TestGraphError(GraphResult);
SetTextStyle(DefaultFont, HorizDir, 1);
SetTextJustify(CenterText, TopText);
MaxColors := GetMaxColor;
BackColor := 0;
ChangeColors := TRUE;
Xmax := GetMaxX;
Ymax := GetMaxY;
ViewXmax := Xmax-2;
ViewYmax := (Ymax-(TextHeight('M')+4)-1)-2;
StartX := Xmax div 2;
StartY := Ymax div 2;
for I := 1 to Memory do with Line[I] do begin
LX1 := StartX; LX2 := StartX;
LY1 := StartY; LY2 := StartY;
end;
X1 := StartX;
X2 := StartX;
Y1 := StartY;
Y2 := StartY;
end; {init}
procedure AdjustX(var X,DeltaX: integer);
var
TestX: integer;
begin
TestX := X+DeltaX;
if (TestX<1) or (TestX>ViewXmax) then begin
TestX := X;
DeltaX := -DeltaX;
end;
X := TestX;
end;
procedure AdjustY(var Y,DeltaY: integer);
var
TestY: integer;
begin
TestY := Y+DeltaY;
if (TestY<1) or (TestY>ViewYmax) then begin
TestY := Y;
DeltaY := -DeltaY;
end;
Y := TestY;
end;
procedure SelectNewColors;
begin
if not ChangeColors then exit;
Colors[1] := Random(MaxColors)+1;
Colors[2] := Random(MaxColors)+1;
Colors[3] := Random(MaxColors)+1;
Colors[4] := Random(MaxColors)+1;
ColorCount := 3*(1+Random(5));
end;
procedure SelectNewDeltaValues;
begin
DeltaX1 := Random(MaxDelta)-(MaxDelta Div 2);
DeltaX2 := Random(MaxDelta)-(MaxDelta Div 2);
DeltaY1 := Random(MaxDelta)-(MaxDelta Div 2);
DeltaY2 := Random(MaxDelta)-(MaxDelta Div 2);
IncrementCount := 2*(1+Random(4));
end;
procedure SaveCurrentLine(CurrentColors: ColorList);
begin
with Line[CurrentLine] do
begin
LX1 := X1;
LY1 := Y1;
LX2 := X2;
LY2 := Y2;
LColor := CurrentColors;
end;
end;
procedure Draw(x1,y1,x2,y2,color:word);
begin
SetColor(color);
Graph.Line(x1,y1,x2,y2);
end;
procedure Regenerate;
var
I: integer;
begin
Frame;
for I := 1 to Memory do with Line[I] do begin
Draw(LX1,LY1,LX2,LY2,LColor[1]);
Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,LColor[2]);
Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,LColor[3]);
Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,LColor[4]);
end;
WaitToGo;
Frame;
end;
procedure Updateline;
begin
Inc(CurrentLine);
if CurrentLine > Memory then CurrentLine := 1;
Dec(ColorCount);
Dec(IncrementCount);
end;
procedure CheckForUserInput;
begin
if KeyPressed then begin
Ch := ReadKey;
if Upcase(Ch) = 'B' then begin
if BackColor > MaxColors then BackColor := 0 else Inc(BackColor);
SetBkColor(BackColor);
end
else
if Upcase(Ch) = 'C' then begin
if ChangeColors then ChangeColors := FALSE else ChangeColors := TRUE;
ColorCount := 0;
end
else if Ch<>#27 then Regenerate;
end;
end;
procedure DrawCurrentLine;
var c1,c2,c3,c4: integer;
begin
c1 := Colors[1];
c2 := Colors[2];
c3 := Colors[3];
c4 := Colors[4];
if MaxColors = 1 then begin
c2 := c1; c3 := c1; c4 := c1;
end;
Draw(X1,Y1,X2,Y2,c1);
Draw(ViewXmax-X1,Y1,ViewXmax-X2,Y2,c2);
Draw(X1,ViewYmax-Y1,X2,ViewYmax-Y2,c3);
if MaxColors = 3 then c4 := Random(3)+1; { alternate colors }
Draw(ViewXmax-X1,ViewYmax-Y1,ViewXmax-X2,ViewYmax-Y2,c4);
SaveCurrentLine(Colors);
end;
procedure EraseCurrentLine;
begin
with Line[CurrentLine] do begin
Draw(LX1,LY1,LX2,LY2,0);
Draw(ViewXmax-LX1,LY1,ViewXmax-LX2,LY2,0);
Draw(LX1,ViewYmax-LY1,LX2,ViewYmax-LY2,0);
Draw(ViewXmax-LX1,ViewYmax-LY1,ViewXmax-LX2,ViewYmax-LY2,0);
end;
end;
procedure DoArt;
begin
SelectNewColors;
repeat
EraseCurrentLine;
if ColorCount = 0 then SelectNewColors;
if IncrementCount=0 then SelectNewDeltaValues;
AdjustX(X1,DeltaX1); AdjustX(X2,DeltaX2);
AdjustY(Y1,DeltaY1); AdjustY(Y2,DeltaY2);
if Random(5)=3 then begin
x1 := (x1+x2) div 2; { shorten the lines }
y2 := (y1+y2) div 2;
end;
DrawCurrentLine;
Updateline;
CheckForUserInput;
until Ch=#27;
end;
begin
Init;
Frame;
MessageFrame('Press a key to stop action, Esc quits.');
DoArt;
CloseGraph;
RestoreCrtMode;
Writeln('The End.');
end.


BIN
Borland Turbo Pascal v55/ATT.BGI Normal file
View File

Binary file not shown.

1423
Borland Turbo Pascal v55/BGIDEMO.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

31
Borland Turbo Pascal v55/BGILINK.MAK Normal file
View File

@ -0,0 +1,31 @@
# Build sample program that uses FONTS.TPU and DRIVERS.TPU
bgilink.exe: drivers.tpu fonts.tpu
tpc bgilink /m
# Build unit with all fonts linked in
fonts.tpu: fonts.pas goth.obj litt.obj sans.obj trip.obj
tpc fonts
goth.obj: goth.chr
binobj goth.chr goth GothicFontProc
litt.obj: litt.chr
binobj litt.chr litt SmallFontProc
sans.obj: sans.chr
binobj sans.chr sans SansSerifFontProc
trip.obj: trip.chr
binobj trip.chr trip TriplexFontProc
# Build unit with all drivers linked in
drivers.tpu: drivers.pas cga.obj egavga.obj herc.obj pc3270.obj att.obj
tpc drivers
cga.obj: cga.bgi
binobj cga.bgi cga CGADriverProc
egavga.obj: egavga.bgi
binobj egavga.bgi egavga EGAVGADriverProc
herc.obj: herc.bgi
binobj herc.bgi herc HercDriverProc
pc3270.obj: pc3270.bgi
binobj pc3270.bgi pc3270 PC3270DriverProc
att.obj: att.bgi
binobj att.bgi att ATTDriverProc


126
Borland Turbo Pascal v55/BGILINK.PAS Normal file
View File

@ -0,0 +1,126 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program BgiLink;
{ This program demonstrates how to link graphics driver and font files
into an EXE file. BGI graphic's drivers and fonts are kept in
separate disk files so they may be dynamically loaded at runtime.
However, sometimes it is preferable to place all auxiliary files
directly into an .EXE. This program, along with its make file
(BGILINK.MAK) and two units (DRIVERS.PAS and FONTS.PAS) links all
the drivers and fonts directly into BGILINK.EXE.
Have these 3 programs in the current drive or directory, or
have them available via a path (both are on Disk II):
MAKE.EXE - Make utility that will build BGILINK.EXE
BINOBJ.EXE - utility program to convert any file into an .OBJ file
Place in the current drive or directory the following files (all
are on Disk III):
BGILINK.PAS - this sample program
DRIVERS.PAS - Pascal unit that will link in all BGI drivers
FONTS.PAS - Pascal unit that will link in all BGI fonts
*.CHR - BGI font files
*.BGI - BGI driver files
BGILINK.MAK - "make" file that builds DRIVERS.TPU, FONT.TPU, and
finally BGILINK.EXE
DIRECTIONS:
1. Run MAKE on the BGILINK.MAK file by typing the following command
at a DOS prompt:
make -fBGIlink.mak
Using BINOBJ.EXE, this will first build .OBJ files out of the driver
files (*.BGI) and then call Turbo Pascal to compile DRIVERS.PAS.
Next, the font files (*.CHR) will be converted to .OBJs and
FONTS.PAS will be compiled. Finally, BGILINK.PAS will be compiled
(it uses DRIVERS.TPU and FONTS.TPU).
2. Run BGILINK.EXE. It contains all the drivers and all the fonts, so it
will run on any system with a graphics card supported by the Graph
unit (CGA, EGA, EGA 64 K, EGA monochrome, Hercules monochrome,
VGA, MCGA, IBM 3270 PC and AT&T 6400).
EXPLANATION
BGILINK.PAS uses DRIVERS.TPU and FONTS.TPU in its uses statement:
uses Drivers, Fonts;
Then, it "registers" the drivers it intends to use (in this case,
all of them, so it will run on any graphics card). Then it registers
all of the fonts it will use (again all of them, just for demonstration
purposes) and finally it does some very modest graphics.
You can easily modify BGILINK.PAS for your own use by commenting out
the calls to RegisterBGIdriver and RegisterBGIfont for drivers and
fonts that your program doesn't use.
For a detailed explanation of registering and linking drivers and fonts,
refer to the RegisterBGIdriver and RegisterBGIfont descriptions in
GRAPH.DOC (on Disk III).
}
uses Graph, { library of graphics routines }
Drivers, { all the BGI drivers }
Fonts; { all the BGI fonts }
var
GraphDriver, GraphMode, Error : integer;
procedure Abort(Msg : string);
begin
Writeln(Msg, ': ', GraphErrorMsg(GraphResult));
Halt(1);
end;
begin
{ Register all the drivers }
if RegisterBGIdriver(@CGADriverProc) < 0 then
Abort('CGA');
if RegisterBGIdriver(@EGAVGADriverProc) < 0 then
Abort('EGA/VGA');
if RegisterBGIdriver(@HercDriverProc) < 0 then
Abort('Herc');
if RegisterBGIdriver(@ATTDriverProc) < 0 then
Abort('AT&T');
if RegisterBGIdriver(@PC3270DriverProc) < 0 then
Abort('PC 3270');
{ Register all the fonts }
if RegisterBGIfont(@GothicFontProc) < 0 then
Abort('Gothic');
if RegisterBGIfont(@SansSerifFontProc) < 0 then
Abort('SansSerif');
if RegisterBGIfont(@SmallFontProc) < 0 then
Abort('Small');
if RegisterBGIfont(@TriplexFontProc) < 0 then
Abort('Triplex');
GraphDriver := Detect; { autodetect the hardware }
InitGraph(GraphDriver, GraphMode, ''); { activate graphics }
if GraphResult <> grOk then { any errors? }
begin
Writeln('Graphics init error: ', GraphErrorMsg(GraphDriver));
Halt(1);
end;
MoveTo(5, 5);
OutText('Drivers and fonts were ');
MoveTo(5, 20);
SetTextStyle(GothicFont, HorizDir, 4);
OutText('Built ');
SetTextStyle(SmallFont, HorizDir, 4);
OutText('into ');
SetTextStyle(TriplexFont, HorizDir, 4);
OutText('EXE ');
SetTextStyle(SansSerifFont, HorizDir, 4);
OutText('file!');
Rectangle(0, 0, GetX, GetY + TextHeight('file!') + 1);
Readln;
CloseGraph;
end.


BIN
Borland Turbo Pascal v55/BINOBJ.EXE Normal file
View File

Binary file not shown.

329
Borland Turbo Pascal v55/BOUNDS.PAS Normal file
View File

@ -0,0 +1,329 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit Bounds;
{ Turbo Pascal 5.5 object-oriented example.
See BREAKOUT.PAS.
Contains the Paddle object type and the object types that
define the boundaries of the playfield.
This unit is part of the BREAKOUT.PAS example.
}
interface
uses Screen, Bricks, Count, Crt;
type
ObstaclePtr = ^Obstacle;
{ An ObstacleList is a list of instances of objects derived from the
object Obstacle. In order to use all these instances polymorphically,
All their virtual functions have to have corresponding virtual functions
in Obstacle, even if they are never used. }
Obstacle = object(Location)
Width : Integer;
Trap : Boolean;
NextPtr : ObstaclePtr;
constructor Init(InitX, InitY, InitWidth : Integer; SetTrap : Boolean);
destructor Done; virtual;
function Collide(var B : Ball) : Boolean; virtual;
function IsTrap : Boolean; virtual;
function GetValue : Integer; virtual;
end;
ObstacleList = object
Head : Obstacle;
Tail : ObstaclePtr;
constructor Init;
destructor Done; virtual;
procedure Append(NewObstacle : ObstaclePtr);
procedure Show;
procedure Hide;
function CheckCollisions(var B : Ball; var Score : Counter) : Boolean;
end;
Paddle = object(Obstacle)
Color : Integer;
constructor Init(InitX, InitY, InitColor : Integer);
destructor Done; virtual;
procedure Show; virtual;
procedure Hide; virtual;
procedure MoveTo(NewX, NewY : Integer); virtual;
function Collide(var B : Ball) : Boolean; virtual;
end;
{ There are no instances of the object Boundary. It's here to provide
a common basis for the next four objects. }
Boundary = object(Obstacle)
constructor Init(InitX, InitY, InitWidth : Integer; SetTrap : Boolean);
end;
LeftBound = object(Boundary)
constructor Init(InitX, InitY, InitWidth : Integer; SetTrap : Boolean);
function Collide(var B : Ball) : Boolean; virtual;
end;
UpperBound = object(Boundary)
constructor Init(InitX, InitY, InitWidth : Integer; SetTrap : Boolean);
function Collide(var B : Ball) : Boolean; virtual;
end;
RightBound = object(Boundary)
constructor Init(InitX, InitY, InitWidth : Integer; SetTrap : Boolean);
function Collide(var B : Ball) : Boolean; virtual;
end;
LowerBound = object(Boundary)
constructor Init(InitX, InitY, InitWidth : Integer; SetTrap : Boolean);
function Collide(var B : Ball) : Boolean; virtual;
end;
implementation
constructor Obstacle.Init(InitX, InitY, InitWidth : Integer;
SetTrap : Boolean);
begin
Location.Init(InitX, InitY);
Width := InitWidth;
Trap := SetTrap;
NextPtr := nil;
end;
destructor Obstacle.Done;
begin
end;
function Obstacle.Collide(var B : Ball) : Boolean;
begin
Collide := True;
end;
function Obstacle.IsTrap : Boolean;
begin
IsTrap := Trap;
end;
function Obstacle.GetValue : Integer;
begin
GetValue := 0;
end;
constructor ObstacleList.Init;
begin
Head.Init(0, 0, 0, False);
Tail := @Head;
end;
destructor ObstacleList.Done;
var
Temp1, Temp2 : ObstaclePtr;
begin
Temp1 := Head.NextPtr;
while Temp1 <> nil do
begin
Temp2 := Temp1;
Temp1 := Temp1^.NextPtr;
Temp2^.Done;
end;
end;
procedure ObstacleList.Append(NewObstacle : ObstaclePtr);
begin
Tail^.NextPtr := NewObstacle;
Tail := NewObstacle;
end;
procedure ObstacleList.Show;
var
Current : ObstaclePtr;
begin
Current := Head.NextPtr;
while Current <> nil do
begin
Current^.Show;
Current := Current^.NextPtr;
end;
end;
procedure ObstacleList.Hide;
var
Current : ObstaclePtr;
begin
Current := Head.NextPtr;
while Current <> nil do
begin
Current^.Hide;
Current := Current^.NextPtr;
end;
end;
{ This function is a little more complex than I like. It checks
whether a collision occurs, and updates the score if one does. }
function ObstacleList.CheckCollisions(var B : Ball;
var Score : Counter) : Boolean;
var
Current : ObstaclePtr;
begin
CheckCollisions := False;
Current := Head.NextPtr;
while Current <> nil do
begin
if Current^.Collide(B) then
begin
Score.Add(Current^.GetValue);
if Current^.IsTrap then
CheckCollisions := True;
end;
Current := Current^.NextPtr;
end;
end;
constructor Paddle.Init(InitX, InitY, InitColor : Integer);
begin
Obstacle.Init(InitX, InitY, 5, False);
Color := InitColor;
end;
destructor Paddle.Done;
begin
Obstacle.Done;
end;
procedure Paddle.Show;
var
Str : String[10];
begin
FillChar(Str[1], Width, Chr(223));
Str[0] := Chr(Width);
Location.Show;
TextColor(Color);
GoToXY(X, Y);
Write(Str);
end;
procedure Paddle.Hide;
begin
Location.Hide;
GoToXY(X, Y);
Write('' : Width);
end;
{ The motion of Paddle is restricted to the 80-character screen }
procedure Paddle.MoveTo(NewX, NewY : Integer);
begin
Hide;
if NewX < 1 then
X := 1
else if NewX > 81 - Width then
X := 81 - Width
else
X := NewX;
Y := NewY;
Show;
end;
{ If the ball hits the paddle we have to change the ball's direction.
Also, to keep the overall logic simpler, if the paddle is at the
edge of the screen and the ball would miss the paddle and go off the
edge, we call it a hit. If we don't do this here, we get into some
complications with bouncing off the sides of the screen }
function Paddle.Collide(var B : Ball) : Boolean;
var
NewX, NewY : Integer;
begin
NewX := B.NextX;
NewY := B.NextY;
Collide := False;
if (NewY = Y) then
if ((NewX >= X) and (NewX < X + Width)) or
((NewX < 1) and (X = 1)) or
((NewX > 80) and (X + Width = 81)) then
begin
B.ReverseY;
{$IFDEF Test} { If the paddle is following the ball, we have to put
in some random behavior so it doesn't get boring. }
B.ChangeXVel(Integer(Random(2))*2-1);
{$ELSE}
B.ChangeXVel(B.GetX - X - 2);
{$ENDIF}
Collide := True;
end;
end;
constructor Boundary.Init(InitX, InitY, InitWidth : Integer;
SetTrap : Boolean);
begin
Obstacle.Init(InitX, InitY, InitWidth, SetTrap);
end;
constructor LeftBound.Init(InitX, InitY, InitWidth : Integer;
SetTrap : Boolean);
begin
Boundary.Init(InitX, InitY, InitWidth, SetTrap);
end;
function LeftBound.Collide(var B : Ball) : Boolean;
begin
Collide := False;
if (B.NextX <= X) and (B.NextY >= Y) and (B.NextY <= Y + Width) then
begin
B.ReverseX;
Collide := True;
end;
end;
constructor UpperBound.Init(InitX, InitY, InitWidth : Integer;
SetTrap : Boolean);
begin
Boundary.Init(InitX, InitY, InitWidth, SetTrap);
end;
function UpperBound.Collide(var B : Ball) : Boolean;
begin
Collide := False;
if (B.NextY <= Y) and (B.NextX >= X) and (B.NextX <= X + Width) then
begin
B.ReverseY;
Collide := True;
end;
end;
constructor RightBound.Init(InitX, InitY, InitWidth : Integer;
SetTrap : Boolean);
begin
Boundary.Init(InitX, InitY, InitWidth, SetTrap);
end;
function RightBound.Collide(var B : Ball) : Boolean;
begin
Collide := False;
if (B.NextX >= X) and (B.NextY >= Y) and (B.NextY <= Y + Width) then
begin
B.ReverseX;
Collide := True;
end;
end;
constructor LowerBound.Init(InitX, InitY, InitWidth : Integer;
SetTrap : Boolean);
begin
Boundary.Init(InitX, InitY, InitWidth, SetTrap);
end;
function LowerBound.Collide(var B : Ball) : Boolean;
begin
Collide := False;
if (B.NextY >= Y) and (B.NextX >= X) and (B.NextX <= X + Width) then
begin
B.ReverseY;
Collide := True;
end;
end;
end.


302
Borland Turbo Pascal v55/BREAKOUT.PAS Normal file
View File

@ -0,0 +1,302 @@
{ Turbo Breakout }
{ Copyright (c) 1989 by Borland International, Inc. }
program Breakout;
{ Turbo Pascal 5.5 object-oriented example.
This is a version of the classic arcade game, Breakout.
SCREEN.PAS
COUNT.PAS
BRICKS.PAS
BOUNDS.PAS
WALLS.PAS
BREAKOUT.PAS
To build an executable file, compile from the command line with:
tpc /b breakout
or load BREAKOUT.PAS into the integrated development
environment and press F9.
When testing the program, you may want to force the paddle to
follow the ball, so you'll never miss. The program contains
conditional compilation directives to produce this version, and
you can build it from the command line with:
tpc /DTest breakout
or load BREAKOUT.PAS into the integrated development
environment, select Alt-O/C/C, type 'Test' (without the quotes,
of course) followed by the Enter key, then select Alt-C/B to
rebuild the executable file.
}
uses Screen, Count, Bricks, Bounds, Walls, Crt, Dos;
var
ss : SaveScreen;
w : Wall;
b : Ball;
p : Paddle;
Speed : LimitCounter;
Left : LeftBound;
Top : UpperBound;
Right : RightBound;
Bottom : LowerBound;
Obstacles : ObstacleList;
PaddleMsg,
SpeedMsg,
StartMsg,
QuitMsg,
PauseMsg1,
PauseMsg2,
TypeMsg : TextString;
Score : Counter;
Highest : Counter;
Balls : DownCounter;
X : Integer;
Finished : Boolean;
FirstGame : Boolean;
TypeInc,
ch : Char;
procedure Startup;
begin
{ First set up the screen and the cursor }
ss.Init;
TextBackground(BLACK);
ClrScr;
{ Create the boundaries of the playfield }
Left.Init(0, 0, 27, False);
Top.Init(0, 0, 82, False);
Right.Init(81, 0, 27, False);
Bottom.Init(0, 24, 82, True);
{ Initialize the score displays }
Score.Init(0, 65, 24, 'Score', 15);
Score.Show;
Highest.Init(0, 60, 25, 'High Score', 14);
Highest.Show;
{ Set up the various menu messages }
PauseMsg1.Init(31, 18, 'Paused. Press any', 15);
PauseMsg2.Init(31, 19, ' key to continue.', 15);
SpeedMsg.Init(5, 23, #24 + #25 + ' to change speed', 14);
StartMsg.Init(5, 24, #17 + #196 + #217 + ' to begin game', 14);
PaddleMsg.Init(5, 24, #27 + #26 + ' to move paddle', 14);
QuitMsg.Init(5, 25, 'ESC to quit', 14);
QuitMsg.Show;
{ Set up the information messages }
Balls.Init(5, 40, 24, -1, 'Balls', 15);
Balls.Show;
Speed.Init(1, 40, 25, 1, 10, 'Speed', 14);
Speed.Show;
{ Build the wall }
w.Init(1, 1, 16, 10);
w.Show;
{ Need to initialize these, even though we're going to move them later }
b.Init(10, 22, 1, -1, YELLOW);
p.Init(8, 23, WHITE);
{ Put the various obstacles into a list. We don't really need
to do this, but it makes changing things around much easier }
Obstacles.Init;
Obstacles.Append(@p);
Obstacles.Append(@w);
Obstacles.Append(@Left);
Obstacles.Append(@Top);
Obstacles.Append(@Right);
Obstacles.Append(@Bottom);
TypeMsg.Init(22, 12, 'Increase typematic rate? (y/n) ', WHITE);
TypeMsg.Show;
repeat
TypeInc := UpCase(ReadKey);
until (TypeInc = 'Y') or (TypeInc = 'N');
TypeMsg.Hide;
if TypeInc = 'Y' then
ss.Speedup;
ss.SetCursor($2000);
Randomize;
FirstGame := True;
end;
procedure NewGame;
begin
Balls.Reset;
Score.Reset;
if not FirstGame then
w.Reset;
X := Random(78) + 3;
b.MoveTo(X, 22);
p.MoveTo(X-2, 23);
b.Show;
p.Show;
Balls.Decrement;
FirstGame := False;
end;
{ This procedure handles keystrokes between games.
It returns False if the user presses ESC, otherwise it returns True. }
function MainMenu : Boolean;
var
Done : Boolean;
begin
MainMenu := True;
Done := False;
SpeedMsg.Show;
StartMsg.Show;
while not Done do
begin
ch := ReadKey;
case ch of
Chr(27) :
begin
MainMenu := False;
Done := True;
end;
#13 : Done := True;
#0 :
begin
ch := ReadKey;
if Ord(ch) = 72 then
Speed.Increment
else if Ord(ch) = 80 then
Speed.Decrement;
end;
end;
end;
SpeedMsg.Hide;
StartMsg.Hide;
end;
{ This procedure handles keystrokes while the game is in progress }
procedure ProcessKeyStroke;
{ Pause the game }
procedure Pause;
begin
PauseMsg1.Show;
PauseMsg2.Show;
ch := ReadKey;
if KeyPressed then
ch := ReadKey; { Swallow extended keystrokes }
PauseMsg1.Hide;
PauseMsg2.Hide;
b.Show;
end;
begin
ch := ReadKey;
case ch of
Chr(27) : Finished := True;
Chr(0) :
begin
ch := ReadKey;
{$IFNDEF Test}
case Ord(ch) of
75: p.MoveTo(p.GetX - 1, p.GetY); { Left Arrow }
77: p.MoveTo(p.GetX + 1, p.GetY); { Right Arrow }
else
Pause;
end;
{$ELSE}
Pause;
{$ENDIF}
end
else
Pause;
end;
end;
{ This procedure checks for collisions with any of the obstacles
and updates the screen accordingly. }
procedure Update;
var
Offset : Integer;
begin
if Obstacles.CheckCollisions(b, Score) then
begin
b.MoveY;
p.MoveTo(b.GetX - 2, p.GetY);
sound(150);
Delay(300);
nosound;
Balls.Decrement;
while KeyPressed do
ch := ReadKey;
end;
b.MoveX;
b.MoveY;
{$IFDEF Test}
p.MoveTo(b.NextX -2, p.GetY);
{$ENDIF}
end;
{ This procedure cleans up when we're exiting from the program }
procedure ShutDown;
begin
b.Hide;
Obstacles.Hide;
Balls.Hide;
Score.Hide;
Obstacles.Done;
ss.Restore;
if TypeInc = 'Y' then
ss.Slowdown;
ClrScr;
end;
{ This procedure plays a game. The main loop allows up to ten keystrokes,
then moves the ball and checks for collisions }
procedure Play;
var
KeyLoops : Integer;
begin
NewGame;
{$IFNDEF Test}
PaddleMsg.Show;
{$ENDIF}
Finished := False;
KeyLoops := 0;
repeat
if KeyPressed then
ProcessKeyStroke;
Inc(KeyLoops);
if (KeyLoops = 10) and not Finished then
begin
KeyLoops := 0;
UpDate;
end;
Delay(12 - Speed.GetValue);
until Finished or Balls.Last;
PaddleMsg.Hide;
end;
begin
Startup;
while MainMenu do
begin
Play;
Balls.Reset;
b.Hide;
p.Hide;
if Score.GetValue > Highest.GetValue then
Highest.SetValue(Score.GetValue);
end;
ShutDown;
end.


151
Borland Turbo Pascal v55/BRICKS.PAS Normal file
View File

@ -0,0 +1,151 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit Bricks;
{ Turbo Pascal 5.5 object-oriented example.
See BREAKOUT.PAS.
This unit contains the Ball object and the object types that
end up as bricks on the screen.
}
interface
uses Screen, Count;
type
Block = object(Location)
Color : Integer;
Width : Integer;
BChar : Char;
constructor Init(InitX, InitY, InitColor, InitWidth : Integer;
InitChr : Char);
procedure Show; virtual;
procedure Hide; virtual;
end;
Ball = object(Block)
XVel : Integer;
YVel : Integer;
constructor Init(InitX, InitY, InitXVel, InitYVel, InitColor : Integer);
function NextX : Integer;
function NextY : Integer;
procedure MoveX;
procedure MoveY;
procedure ReverseX;
procedure ReverseY;
procedure ChangeXVel(Delta : Integer);
end;
Brick = object(Block)
Value : Integer;
constructor Init(InitX, InitY, InitColor, InitValue : Integer);
function GetValue : Integer;
end;
implementation
uses Crt;
constructor Block.Init(InitX, InitY, InitColor, InitWidth : Integer;
InitChr : Char);
begin
Location.Init(InitX, InitY);
Color := InitColor;
Width := InitWidth;
BChar := InitChr;
end;
procedure Block.Show;
var
Str : String[10];
begin
FillChar(Str[1], Width, BChar);
Str[0] := Chr(Width);
Location.Show;
TextColor(Color);
GoToXY(X, Y);
Write(Str);
end;
procedure Block.Hide;
begin
Location.Hide;
GoToXY(X, Y);
Write('' : Width);
end;
constructor Brick.Init(InitX, InitY, InitColor, InitValue : Integer);
var
BlockChar : Char;
begin
BlockChar := Chr($B2);
if (LastMode = Mono) and Odd(InitX + InitY) then
BlockChar := Chr($B0);
Block.Init(InitX, InitY, InitColor, 5, BlockChar);
Value := InitValue;
end;
function Brick.GetValue : Integer;
begin
GetValue := Value;
end;
constructor Ball.Init(InitX, InitY, InitXVel, InitYVel, InitColor : Integer);
begin
Block.Init(InitX, InitY, InitColor, 1, Chr(15));
XVel := InitXVel;
YVel := InitYVel;
end;
function Ball.NextX : Integer;
begin
NextX := X + XVel;
end;
function Ball.NextY : Integer;
begin
NextY := Y + YVel;
end;
procedure Ball.MoveX;
begin
Hide;
X := NextX;
Show;
end;
procedure Ball.MoveY;
begin
Hide;
Y := NextY;
Show;
end;
procedure Ball.ReverseX;
begin
XVel := -XVel;
end;
procedure Ball.ReverseY;
begin
YVel := -YVel;
end;
{ This procedure introduces the variations in horizontal velocity for
the ball. Horizontal velocity ranges from -2 to 2. If you hit the
ball with the edge of the paddle, you'll get a large change in
horizontal velocity. }
procedure Ball.ChangeXVel(Delta : Integer);
begin
Inc(XVel, Delta);
if XVel < -2 then
XVel := -2
else if XVel > 2 then
XVel := 2
else if XVel = 0 then
XVel := Integer(Random(2))*2 - 1;
end;
end.


219
Borland Turbo Pascal v55/BUFSTM.ASM Normal file
View File

@ -0,0 +1,219 @@
; Turbo Pascal 5.5 object-oriented example
; Assembler code for OBJECTS.PAS unit
; Copyright (c) 1989 by Borland International, Inc.
TITLE BUFSTM
INCLUDE OBJECTS.INC
CODE SEGMENT BYTE PUBLIC
EXTRN StreamError:NEAR
EXTRN DosStream@GetPos:NEAR
ASSUME CS:CODE
PUBLIC BufStream@Flush
BufStream@Flush PROC FAR
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CMP ES:[DI].Stream@Status,0
JNE @@1
MOV AL,2
CALL FlushBuffer
@@1: POP BP
RET 4
BufStream@Flush ENDP
PUBLIC BufStream@GetPos
BufStream@GetPos PROC FAR
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
PUSH ES
PUSH DI
PUSH CS
CALL DosStream@GetPos
OR DX,DX
JS @@1
LES DI,@Self
SUB AX,ES:[DI].BufStream@BufEnd
SBB DX,0
ADD AX,ES:[DI].BufStream@BufPtr
ADC DX,0
@@1: POP BP
RET 4
BufStream@GetPos ENDP
PUBLIC BufStream@Read
BufStream@Read PROC FAR
@Buf EQU (DWORD PTR [BP+12])
@Count EQU (WORD PTR [BP+10])
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CMP ES:[DI].Stream@Status,0
JNE @@6
MOV AL,1
CALL FlushBuffer
JNE @@6
XOR DX,DX
@@1: MOV CX,@Count
SUB CX,DX
JE @@7
LES DI,@Self
MOV AX,ES:[DI].BufStream@BufEnd
SUB AX,ES:[DI].BufStream@BufPtr
JA @@2
PUSH CX
PUSH DX
PUSH DS
LDS DX,ES:[DI].BufStream@Buffer
MOV CX,ES:[DI].BufStream@BufSize
MOV BX,ES:[DI].DosStream@Handle
MOV AH,3FH
INT 21H
POP DS
POP DX
POP CX
JC @@5
MOV ES:[DI].BufStream@BufPtr,0
MOV ES:[DI].BufStream@BufEnd,AX
OR AX,AX
JE @@4
@@2: CMP CX,AX
JB @@3
MOV CX,AX
@@3: PUSH DS
LDS SI,ES:[DI].BufStream@Buffer
ADD SI,ES:[DI].BufStream@BufPtr
ADD ES:[DI].BufStream@BufPtr,CX
LES DI,@Buf
ADD DI,DX
ADD DX,CX
CLD
REP MOVSB
POP DS
JMP @@1
@@4: MOV AX,101
@@5: CALL StreamError
@@6: LES DI,@Buf
MOV CX,@Count
XOR AL,AL
CLD
REP STOSB
@@7: POP BP
RET 10
BufStream@Read ENDP
PUBLIC BufStream@Write
BufStream@Write PROC FAR
@Buf EQU (DWORD PTR [BP+12])
@Count EQU (WORD PTR [BP+10])
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CMP ES:[DI].Stream@Status,0
JNE @@4
MOV AL,0
CALL FlushBuffer
JNE @@4
XOR DX,DX
@@1: MOV CX,@Count
SUB CX,DX
JE @@4
LES DI,@Self
MOV AX,ES:[DI].BufStream@BufSize
SUB AX,ES:[DI].BufStream@BufPtr
JA @@2
PUSH CX
PUSH DX
MOV AL,1
CALL FlushBuffer
POP DX
POP CX
JNE @@4
MOV AX,ES:[DI].BufStream@BufSize
@@2: CMP CX,AX
JB @@3
MOV CX,AX
@@3: PUSH DS
MOV AX,ES:[DI].BufStream@BufPtr
ADD ES:[DI].BufStream@BufPtr,CX
LES DI,ES:[DI].BufStream@Buffer
ADD DI,AX
LDS SI,@Buf
ADD SI,DX
ADD DX,CX
CLD
REP MOVSB
POP DS
JMP @@1
@@4: POP BP
RET 10
BufStream@Write ENDP
; Flush stream buffer
; In AL = Flush mode (0=Read,1=Write,2=Both)
; ES:DI = BufStream pointer
; Out ZF = Status test
FlushBuffer PROC NEAR
MOV CX,ES:[DI].BufStream@BufPtr
SUB CX,ES:[DI].BufStream@BufEnd
JE @@4
MOV BX,ES:[DI].DosStream@Handle
JA @@1
CMP AL,1
JE @@4
MOV DX,CX
MOV CX,-1
MOV AX,4201H
INT 21H
JMP SHORT @@3
@@1: CMP AL,0
JE @@4
PUSH DS
LDS DX,ES:[DI].BufStream@Buffer
MOV AH,40H
INT 21H
POP DS
JC @@2
CMP AX,CX
JE @@3
MOV AX,101
@@2: CALL StreamError
@@3: XOR AX,AX
MOV ES:[DI].BufStream@BufPtr,AX
MOV ES:[DI].BufStream@BufEnd,AX
CMP AX,ES:[DI].Stream@Status
@@4: RET
FlushBuffer ENDP
CODE ENDS
END


BIN
Borland Turbo Pascal v55/BUFSTM.OBJ Normal file
View File

Binary file not shown.

137
Borland Turbo Pascal v55/CARDFILE.PAS Normal file
View File

@ -0,0 +1,137 @@
{ Turbo Cardfile }
{ Copyright (c) 1989 by Borland International, Inc. }
program CardFile;
{ Turbo Pascal 5.5 object-oriented example.
Demonstrates the use of the CARDS unit.
Refer to OOPDEMOS.DOC for an overview of this program.
}
{$S-}
{$M 8192, 65536, 655360}
uses Crt, Objects, Forms, Sliders, Cards;
const
Signature: Longint = $44524143;
var
F: Form;
C: CardList;
S: FStream;
procedure Error(Message: String);
begin
WriteLn(Message, ': ', ParamStr(1));
Halt(1);
end;
procedure ReadCards;
var
Header: Longint;
begin
S.Init(ParamStr(1), SOpen, 1024);
if S.Status <> 0 then Error('Cannot open file');
S.Read(Header, SizeOf(Longint));
if Header <> Signature then Error('File format error');
F.Load(S);
C.Load(S);
if S.Status <> 0 then Error('Disk read error');
S.Done;
end;
function EditCards: Boolean;
var
Ch: Char;
Start, Stop: Boolean;
function EditForm: Boolean;
begin
Color(ForeColor);
GotoXY(1, 25);
Write(' Edit '#179' F2-Accept Esc-Cancel');
ClrEol;
EditForm := F.Edit = CSave;
end;
function Confirm(Message: String): Boolean;
begin
Color(ForeColor);
GotoXY(1, 25);
Write(' ', Message, ' (Y/N)? ');
ClrEol;
Confirm := UpCase(ReadChar) = 'Y';
end;
begin
Color(BackColor);
ClrScr;
Color(ForeColor);
GotoXY(1, 1);
Write(' File ', ParamStr(1));
ClrEol;
Start := True;
Stop := False;
repeat
if C.Count = 0 then F.Clear else F.Put(C.CardData^);
F.Show(Start);
Color(ForeColor);
GotoXY(69, 1);
Write(C.Count: 5, ' Cards');
GotoXY(1, 25);
Write(' Browse '#179' '#25'-Next '#24'-Prev Enter-Edit ' +
'Ins-Insert Del-Delete Esc-Exit ');
ClrEol;
Ch := ReadChar;
if (Ch = CEnter) and (C.Count = 0) then Ch := CIns;
case Ch of
CNext: C.Next;
CPrev: C.Prev;
CEnter: if EditForm then F.Get(C.CardData^);
CIns:
begin
F.Clear;
F.Show(False);
if EditForm then
begin
C.Insert;
F.Get(C.CardData^);
end;
end;
CDel:
if C.Count > 0 then
if Confirm('Delete this card') then C.Delete;
CEsc: Stop := True;
else
Beep;
end;
Start := False;
until Stop;
EditCards := Confirm('Update card file');
NormVideo;
ClrScr;
end;
procedure WriteCards;
begin
S.Init(ParamStr(1), SCreate, 1024);
if S.Status <> 0 then Error('Cannot create file');
S.Write(Signature, SizeOf(Longint));
F.Store(S);
C.Store(S);
S.Flush;
if S.Status <> 0 then Error('Disk write error');
S.Done;
end;
begin
if ParamCount <> 1 then
begin
WriteLn('Usage: CARDFILE filename');
Halt(1);
end;
ReadCards;
if EditCards then WriteCards;
end.


76
Borland Turbo Pascal v55/CARDGEN.PAS Normal file
View File

@ -0,0 +1,76 @@
{ Turbo Generator }
{ Copyright (c) 1989 by Borland International, Inc. }
program CardGen;
{ Turbo Pascal 5.5 object-oriented example.
Generates example OOP databases for CARDFILE.PAS.
Refer to OOPDEMOS.DOC for an overview of this program.
}
{$S-}
{$M 8192, 16384, 16384}
uses Crt, Objects, Forms, Sliders, Cards;
const
Signature: Longint = $44524143; { unique signature for file }
var
F: Form;
C: CardList;
S: FStream;
procedure PeopleForm;
{ Create an example form in memory with "People" info }
begin
F.Init(10, 5, 54, 16);
F.Add(New(FStrPtr, Init(3, 2, ' Firstname ', 30)));
F.Add(New(FStrPtr, Init(3, 3, ' Lastname ', 30)));
F.Add(New(FStrPtr, Init(3, 5, ' Address ', 32)));
F.Add(New(FStrPtr, Init(3, 6, ' City ', 16)));
F.Add(New(FStrPtr, Init(25, 6, ' State ', 2)));
F.Add(New(FZipPtr, Init(34, 6, ' Zip ')));
F.Add(New(FIntPtr, Init(3, 8, ' Counter 1 ', 0, 99999999)));
F.Add(New(FIntPtr, Init(22, 8, ' 2 ', 0, 99999999)));
F.Add(New(FIntPtr, Init(33, 8, ' 3 ', 0, 99999999)));
F.Add(New(FSliderPtr, Init(3, 10, ' Slider One ', 0, 100, 5)));
F.Add(New(FSliderPtr, Init(3, 11, ' Slider Two ', 0, 100, 5)));
end;
procedure PartsForm;
{ Create an example form in memory with "Parts" info }
begin
F.Init(12, 7, 68, 14);
F.Add(New(FStrPtr, Init(3, 2, ' Part Code ', 10)));
F.Add(New(FRealPtr, Init(24, 2, ' Cost ', 9, 2)));
F.Add(New(FRealPtr, Init(39, 2, ' Retail ', 9, 2)));
F.Add(New(FStrPtr, Init(3, 4, ' Description ', 40)));
F.Add(New(FStrPtr, Init(3, 5, ' Description ', 40)));
F.Add(New(FIntPtr, Init(3, 7, ' Units On Hand ', 0, 999999)));
F.Add(New(FIntPtr, Init(24, 7, ' Backorder ', 0, 999999)));
F.Add(New(FIntPtr, Init(41, 7, ' Shipped ', 0, 999999)));
end;
procedure MakeFile(FileName: FNameStr);
{ Use a stream to create a cardfile with a form and no data }
begin
C.Init(F.Size);
S.Init(FileName, SCreate, 1024);
S.Write(Signature, SizeOf(Longint));
F.Store(S);
C.Store(S);
S.Flush;
if S.Status <> 0 then WriteLn('Error creating file ', FileName);
S.Done;
C.Done;
F.Done;
end;
begin
PeopleForm;
MakeFile('PEOPLE.DTA');
PartsForm;
MakeFile('PARTS.DTA');
end.


BIN
Borland Turbo Pascal v55/CARDS.DTA Normal file
View File

Binary file not shown.

136
Borland Turbo Pascal v55/CARDS.PAS Normal file
View File

@ -0,0 +1,136 @@
{ Turbo Cards }
{ Copyright (c) 1989 by Borland International, Inc. }
unit Cards;
{ Turbo Pascal 5.5 object-oriented example.
This unit defines a Rolodex-like database of cards.
Refer to OOPDEMOS.DOC for an overview of this unit.
}
{$S-}
interface
uses Objects;
type
CardNodePtr = ^CardNode;
CardNode = record
Next: CardNodePtr;
Prev: CardNodePtr;
Data: record end;
end;
CardListPtr = ^CardList;
CardList = object(Base)
Current: CardNodePtr;
Count, DataSize: Integer;
constructor Init(PDataSize: Integer);
constructor Load(var S: Stream);
destructor Done; virtual;
function CardData: Pointer;
procedure Delete;
procedure Insert;
procedure Next;
procedure Prev;
procedure Store(var S: Stream);
end;
implementation
constructor CardList.Init(PDataSize: Integer);
begin
Current := nil;
Count := 0;
DataSize := PDataSize;
end;
constructor CardList.Load(var S: Stream);
var
I, N: Integer;
begin
Current := nil;
Count := 0;
S.Read(N, SizeOf(Integer));
S.Read(DataSize, SizeOf(Integer));
for I := 1 to N do
begin
Insert;
S.Read(Current^.Data, DataSize);
end;
Next;
end;
destructor CardList.Done;
var
I: Integer;
begin
for I := 1 to Count do Delete;
end;
function CardList.CardData: Pointer;
begin
CardData := @Current^.Data;
end;
procedure CardList.Delete;
var
N: CardNodePtr;
begin
Dec(Count);
N := Current;
if Count = 0 then Current := nil else
begin
Current := N^.Prev;
Current^.Next := N^.Next;
N^.Next^.Prev := Current;
end;
FreeMem(N, DataSize + SizeOf(CardNode));
end;
procedure CardList.Insert;
var
N: CardNodePtr;
begin
GetMem(N, DataSize + SizeOf(CardNode));
if Count = 0 then
begin
N^.Next := N;
N^.Prev := N;
end else
begin
N^.Next := Current^.Next;
Current^.Next^.Prev := N;
N^.Prev := Current;
Current^.Next := N;
end;
Current := N;
Inc(Count);
end;
procedure CardList.Next;
begin
if Current <> nil then Current := Current^.Next;
end;
procedure CardList.Prev;
begin
if Current <> nil then Current := Current^.Prev;
end;
procedure CardList.Store(var S: Stream);
var
I: Integer;
begin
S.Write(Count, SizeOf(Integer) * 2);
for I := 1 to Count do
begin
S.Write(Current^.Data, DataSize);
Next;
end;
end;
end.


BIN
Borland Turbo Pascal v55/CGA.BGI Normal file
View File

Binary file not shown.

24
Borland Turbo Pascal v55/CIRCULAR.PAS Normal file
View File

@ -0,0 +1,24 @@
{ Turbo Reference }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program Circular;
{ Simple program that demonstrates circular unit references via
a USES clause in the implementation section.
Note that it is NOT possible for the two units to "USE" each
other in their interface sections. It is possible for AA's
interface to use BB, and BB's implementation to use AA, but
this is tricky and depends on compilation order. We don't
document or recommend it.
}
uses
Crt, Display, Error;
begin
ClrScr;
WriteXY(1, 1, 'Upper left');
WriteXY(100, 100, 'Off the screen');
WriteXY(81 - Length('Back to reality'), 15, 'Back to reality');
end.


239
Borland Turbo Pascal v55/COUNT.PAS Normal file
View File

@ -0,0 +1,239 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit Count;
{ Turbo Pascal 5.5 object-oriented example.
See BREAKOUT.PAS.
This unit provides several text display object types, most of
which are coupled with various types of counters.
}
interface
uses Screen;
const
StrSize = 40;
type
TextStr = String[StrSize];
TextPtr = ^TextStr;
TextString = object(Location)
Text : TextPtr;
Attr : Byte;
constructor Init(InitX, InitY : Integer;
InitText : TextStr;
InitAttr : Byte);
procedure Show; virtual;
procedure Hide; virtual;
end;
Counter = object(TextString)
Value : Integer;
BaseValue : Integer;
constructor Init(InitValue, InitX, InitY : Integer;
InitName : TextStr;
InitAttr : Byte);
procedure Show; virtual;
procedure Hide; virtual;
procedure ShowVal; virtual;
procedure HideVal; virtual;
procedure SetValue(NewValue : Integer);
procedure Reset;
procedure Increment;
procedure Decrement;
procedure Add(Incr : Integer);
function Equal(TestValue : Integer) : Boolean;
function GetValue : Integer;
end;
DownCounter = object(Counter)
Minimum : Integer;
constructor Init(InitValue, InitX, InitY, InitMin : Integer;
InitName : TextStr;
InitAttr : Byte);
procedure Decrement;
procedure Add(Incr : Integer);
function Last : Boolean;
end;
LimitCounter = object(DownCounter)
Maximum : Integer;
constructor Init(InitValue, InitX, InitY, InitMin, InitMax : Integer;
InitName : TextStr;
InitAttr : Byte);
procedure Increment;
procedure Add(Incr : Integer);
end;
implementation
uses Crt;
constructor TextString.Init(InitX, InitY : Integer;
InitText : TextStr;
InitAttr : Byte);
begin
Location.Init(InitX, InitY);
Attr := InitAttr;
GetMem(Text, Length(InitText) + 1);
Move(InitText, Text^, Length(InitText) + 1);
end;
procedure TextString.Show;
begin
Visible := True;
GoToXY(X, Y);
TextColor(Attr);
Write(Text^);
end;
procedure TextString.Hide;
begin
Visible := False;
GoToXY(X, Y);
TextAttr := Attr;
Write('' : Length(Text^));
end;
constructor Counter.Init(InitValue, InitX, InitY : Integer;
InitName : TextStr;
InitAttr : Byte);
begin
TextString.Init(InitX, InitY, InitName, InitAttr);
BaseValue := InitValue;
Value := InitValue;
end;
procedure Counter.Show;
begin
Visible := True;
GoToXY(X, Y);
TextColor(Attr);
Write(Text^, ': ', Value);
end;
procedure Counter.Hide;
begin
Visible := False;
GoToXY(X, Y);
TextAttr := Attr;
Write('' : Length(Text^) + 7);
end;
procedure Counter.ShowVal;
begin
Visible := True;
GoToXY(X + Length(Text^) + 2, Y);
TextColor(Attr);
Write(Value);
end;
procedure Counter.HideVal;
begin
Visible := False;
GoToXY(X + Length(Text^) + 2, Y);
TextAttr := Attr;
Write('' : 5);
end;
procedure Counter.SetValue(NewValue : Integer);
var
Vis : Boolean;
begin
Vis := Visible;
if Vis then
HideVal;
Value := NewValue;
if Vis then
ShowVal;
end;
procedure Counter.Increment;
begin
SetValue(Value + 1);
end;
procedure Counter.Decrement;
begin
SetValue(Value - 1);
end;
procedure Counter.Add(Incr : Integer);
begin
SetValue(Value + Incr);
end;
procedure Counter.Reset;
begin
SetValue(BaseValue);
end;
function Counter.Equal(TestValue : Integer) : Boolean;
begin
Equal := (Value = TestValue);
end;
function Counter.GetValue : Integer;
begin
GetValue := Value;
end;
constructor DownCounter.Init(InitValue, InitX, InitY, InitMin : Integer;
InitName : TextStr;
InitAttr : Byte);
begin
Counter.Init(InitValue, InitX, InitY, InitName, InitAttr);
Minimum := InitMin;
end;
procedure DownCounter.Decrement;
begin
if Value > Minimum then
Counter.Decrement;
end;
procedure DownCounter.Add(Incr : Integer);
var
Temp : Integer;
begin
Temp := GetValue + Incr;
if Temp >= Minimum then
SetValue(Temp);
end;
function DownCounter.Last : Boolean;
begin
Last := (Value = Minimum);
end;
constructor LimitCounter.Init(InitValue,
InitX,
InitY,
InitMin,
InitMax : Integer;
InitName : TextStr;
InitAttr : Byte);
begin
DownCounter.Init(InitValue, InitX, InitY, InitMin, InitName, InitAttr);
Maximum := InitMax;
end;
procedure LimitCounter.Increment;
begin
if Value < Maximum then
Counter.Increment;
end;
procedure LimitCounter.Add(Incr : Integer);
var
Temp : Integer;
begin
Temp := Value + Incr;
if (Temp <= Maximum) and (Temp >= Minimum) then
SetValue(Temp);
end;
end.


75
Borland Turbo Pascal v55/CPASDEMO.C Normal file
View File

@ -0,0 +1,75 @@
/* Copyright (c) 1985, 1989 by Borland International, Inc.
This module demonstrates how to write Turbo C routines that
can be linked into a Turbo Pascal program. Routines in this
module call Turbo Pascal routines in CPASDEMO.PAS.
See the instructions in the file CPASDEMO.PAS on running
this demonstration program */
typedef unsigned int word;
typedef unsigned char byte;
typedef unsigned long longword;
extern void setcolor(byte newcolor); /* procedure defined in
Turbo Pascal program */
extern word factor; /* variable declared in Turbo Pascal program */
word sqr(int i)
{
setcolor(1);
return(i * i);
} /* sqr */
word hibits(word w)
{
setcolor(2);
return(w >> 8);
} /* hibits */
byte suc(byte b)
{
setcolor(3);
return(++b);
} /* suc */
byte upr(byte c)
{
setcolor(4);
return((c >= 'a') && (c <= 'z') ? c - 32 : c);
} /* upr */
char prd(char s)
{
setcolor(5);
return(--s);
} /* prd */
long lobits(long l)
{
setcolor(6);
return((longword)l & 65535);
} /* lobits */
void strupr(char far *s)
{
int counter;
for (counter = 1; counter <= s[0]; counter++) /* Note that the routine */
s[counter] = upr(s[counter]); /* skips Turbo Pascal's */
setcolor(7); /* length byte */
} /* strupr */
byte boolnot(byte b)
{
setcolor(8);
return(b == 0 ? 1 : 0);
} /* boolnot */
word multbyfactor(word w)
{
setcolor(9); /* note that this function accesses the Turbo Pascal */
return(w * factor); /* declared variable factor */
} /* multbyfactor */


126
Borland Turbo Pascal v55/CPASDEMO.PAS Normal file
View File

@ -0,0 +1,126 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program CPASDEMO;
(*
This program demonstrates how to interface Turbo Pascal and Turbo C.
Turbo C is used to generate an .OBJ file (CPASDEMO.OBJ). Then
this .OBJ is linked into this Turbo Pascal program using the {$L}
compiler directive.
NOTES:
1. Data declared in the Turbo C module cannot be accessed from
the Turbo Pascal program. Shared data must be declared in
Pascal.
2. If the C functions are only used in the implementation section
of a unit, declare them NEAR. If they are declared in the
interface section of a unit, declare them FAR. Always compile
the Turbo C modules using the small memory model.
3. Turbo C runtime library routines cannot be used because their
modules do not have the correct segment names. However, if you have
the Turbo C runtime library source (available from Borland),
you can use individual library modules by recompiling
them using CTOPAS.BAT. If you do recompile them, make sure
that you include prototypes in your C module for all C
library functions that you use.
4. Some of the code that Turbo C generates are calls to internal
routines. These cannot be used without recompiling the relevant
parts of the Turbo C runtime library source code.
In order to run this demonstration program you will need the following
files:
TCC.EXE and TURBO.CFG or
TC.EXE and CTOPAS.TC
To run the demonstration program CPASDEMO.EXE do the following:
1. First create a CPASDEMO.OBJ file compatible with Turbo Pascal 5.5
using Turbo C.
a) If you are using the Turbo C integrated environment (TC.EXE)
then at the DOS prompt execute:
TC /CCTOPAS.TC CPASDEMO.C
then create the .OBJ file by pressing ALT-F9.
b) If you are using the Turbo C command line version (TCC.EXE)
then at the DOS prompt execute:
TCC CPASDEMO.C
Note: Use the same configuration file (TURBO.CFG or CTOPAS.TC)
when you create your own Turbo C modules for use with
Turbo Pascal 5.5
2. Compile and execute the Turbo Pascal program CPASDEMO.PAS
This simple program calls each of the functions defined in the Turbo C
module. Each of the Turbo C functions changes the current display color
by calling the Turbo Pascal procedure SetColor.
*)
uses Crt;
var
Factor : Word;
{$L CPASDEMO.OBJ} { link in the Turbo C-generated .OBJ module }
function Sqr(I : Integer) : Word; external;
{ Change the text color and return the square of I }
function HiBits(W : Word) : Word; external;
{ Change the text color and return the high byte of W }
function Suc(B : Byte) : Byte; external;
{ Change the text color and return B + 1 }
function Upr(C : Char) : Char; external;
{ Change the text color and return the upper case of C }
function Prd(S : ShortInt) : ShortInt; external;
{ Change the text color and return S - 1 }
function LoBits(L : LongInt) : LongInt; external;
{ Change the text color and return the low word of L }
procedure StrUpr(var S : string); external;
{ Change the text color and return the upper case of S - Note that the Turbo }
{ C routine must skip the length byte of the string. }
function BoolNot(B : Boolean) : Boolean; external;
{ Change the text color and return NOT B }
function MultByFactor(W : Word) : Word; external;
{ Change the text color and return W * Factor - note Turbo C's access of }
{ Turbo Pascal's global variable. }
procedure SetColor(NewColor : Byte); { A procedure that changes the current }
begin { display color by changing the CRT }
TextAttr := NewColor; { variable TextAttr }
end; { SetColor }
var
S : string;
begin
Writeln(Sqr(10)); { Call each of the functions defined }
Writeln(HiBits(30000)); { passing it the appropriate info. }
Writeln(Suc(200));
Writeln(Upr('x'));
Writeln(Prd(-100));
Writeln(LoBits(100000));
S := 'abcdefg';
StrUpr(S);
Writeln(S);
Writeln(BoolNot(False));
Factor := 100;
Writeln(MultbyFactor(10));
SetColor(LightGray);
end.


147
Borland Turbo Pascal v55/CRTDEMO.PAS Normal file
View File

@ -0,0 +1,147 @@
{ Turbo Crt }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program CrtDemo;
{ Example program that uses the Crt unit. Uses the following routines
from the Crt unit:
ClrScr
DelLine
GoToXY
InsLine
KeyPressed
ReadKey
TextBackground
TextColor
TextMode
WhereX
WhereY
Window
Write
WriteLn;
Also uses LastMode and WindMax variables from Crt unit.
1. Init routine:
- Save original video mode. On an EGA or VGA, use the 8x8 font
(43 lines on an EGA, 50 on VGA).
- Setup LastRow to preserve last line on screen for messages
(preserves last 2 lines in 40-column mode). Setup LastCol.
- Initialize the random number generator.
2. MakeWindow routine:
- Puts up random-sized, random-colored windows on screen.
3. Program body:
- Call Init
- Loop until Contrl-C is typed:
- Echo keystrokes (Turbo Pascal windows automatically wrap
and scroll).
- Support special keys:
<Ins> inserts a line at the cursor
<Del> deletes a line at the cursor
<Up>,
<Dn>,
<Right>,
<Left> position the cursor in the window
<Alt-R> generate random text until a key is pressed
<Alt-W> creates another random window
<ESC> exits the program
}
uses Crt;
var
OrigMode,LastCol,LastRow: Word;
Ch: Char;
Done: Boolean;
procedure Initialize;
{ Initialize the video mode, LastCol, LastRow, and the random number }
{ generator. Paint the help line. }
begin
CheckBreak:=False; { turn off Contrl-C checking }
OrigMode:=LastMode; { Remember original video mode }
TextMode(Lo(LastMode)+Font8x8); { use 43 or 50 lines on EGA/VGA }
LastCol:=Lo(WindMax)+1; { get last column, row }
LastRow:=Hi(WindMax)+1;
GoToXY(1,LastRow); { put message line on screen }
TextBackground(Black);
TextColor(White);
Write(' Ins-InsLine ',
'Del-DelLine ',
#27#24#25#26'-Cursor ',
'Alt-W-Window ',
'Alt-R-Random ',
'Esc-Exit');
Dec(LastRow,80 div LastCol); { don't write on message line }
Randomize; { init random number generator }
end; { Init }
procedure MakeWindow;
{ Make a random window, with random background and foreground colors }
var
X,Y,Width,Height: Word;
begin
Width:=Random(LastCol-2)+2; { random window size }
Height:=Random(LastRow-2)+2;
X:=Random(LastCol-Width)+1; { random position on screen }
Y:=Random(LastRow-Height)+1;
Window(X,Y,X+Width,Y+Height);
if OrigMode = Mono then
begin
TextBackground(White);
TextColor(Black);
ClrScr;
Window(X+1,Y+1,X+Width-1,Y+Height-1);
TextBackground(Black);
TextColor(White);
ClrScr;
end
else
begin
TextBackground(Random(8));
TextColor(Random(7)+9);
end;
ClrScr;
end; { MakeWindow }
procedure RandomText;
{ Generate random text until a key is pressed. Filter out }
{ control characters. }
begin
repeat
Write(Chr(Random(256-32)+32));
until KeyPressed;
end; { RandomText }
begin { program body }
Initialize;
MakeWindow;
Done:=False;
repeat
Ch:=ReadKey;
case Ch of
#0: { Function keys }
begin
Ch:=ReadKey;
case Ch of
#17: MakeWindow; { Alt-W }
#19: RandomText; { Alt-R }
#45: Done:=True; { Alt-X }
#72: GotoXY(WhereX,WhereY-1); { Up }
#75: GotoXY(WhereX-1,WhereY); { Left }
#77: GotoXY(WhereX+1,WhereY); { Right }
#80: GotoXY(WhereX,WhereY+1); { Down }
#82: InsLine; { Ins }
#83: DelLine; { Del }
end;
end;
#3: Done:=True; { Ctrl-C }
#13: WriteLn; { Enter }
#27: Done:=True; { Esc }
else
Write(Ch);
end;
until Done;
TextMode(OrigMode);
end.


BIN
Borland Turbo Pascal v55/CTOPAS.TC Normal file
View File

Binary file not shown.

240
Borland Turbo Pascal v55/DIRDEMO.PAS Normal file
View File

@ -0,0 +1,240 @@
{ Turbo Directory }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program DirDemo;
{ Demonstration program that shows how to use:
o Directory routines from DOS unit
o Procedural types (used by QuickSort)
Usage:
dirdemo [options] [directory mask]
Options:
-W Wide display
-N Sort by file name
-S Sort by file size
-T Sort by file date and time
Directory mask:
Path, Filename, wildcards, etc.
}
{$I-,S-}
{$M 8192,8192,655360}
uses Dos;
const
MaxDirSize = 512;
MonthStr: array[1..12] of string[3] = (
'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
type
DirPtr = ^DirRec;
DirRec = record
Attr: Byte;
Time: Longint;
Size: Longint;
Name: string[12];
end;
DirList = array[0..MaxDirSize - 1] of DirPtr;
LessFunc = function(X, Y: DirPtr): Boolean;
var
WideDir: Boolean;
Count: Integer;
Less: LessFunc;
Path: PathStr;
Dir: DirList;
function NumStr(N, D: Integer): String;
begin
NumStr[0] := Chr(D);
while D > 0 do
begin
NumStr[D] := Chr(N mod 10 + Ord('0'));
N := N div 10;
Dec(D);
end;
end;
{$F+}
function LessName(X, Y: DirPtr): Boolean;
begin
LessName := X^.Name < Y^.Name;
end;
function LessSize(X, Y: DirPtr): Boolean;
begin
LessSize := X^.Size < Y^.Size;
end;
function LessTime(X, Y: DirPtr): Boolean;
begin
LessTime := X^.Time > Y^.Time;
end;
{$F-}
procedure QuickSort(L, R: Integer);
var
I, J: Integer;
X, Y: DirPtr;
begin
I := L;
J := R;
X := Dir[(L + R) div 2];
repeat
while Less(Dir[I], X) do Inc(I);
while Less(X, Dir[J]) do Dec(J);
if I <= J then
begin
Y := Dir[I];
Dir[I] := Dir[J];
Dir[J] := Y;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then QuickSort(L, J);
if I < R then QuickSort(I, R);
end;
procedure GetCommand;
var
I,J: Integer;
Attr: Word;
S: PathStr;
D: DirStr;
N: NameStr;
E: ExtStr;
F: File;
begin
WideDir := False;
@Less := nil;
Path := '';
for I := 1 to ParamCount do
begin
S := ParamStr(I);
if S[1] = '-' then
for J := 2 to Length(S) do
case UpCase(S[J]) of
'N': Less := LessName;
'S': Less := LessSize;
'T': Less := LessTime;
'W': WideDir := True;
else
WriteLn('Invalid option: ', S[J]);
Halt(1);
end
else
Path := S;
end;
Path := FExpand(Path);
if Path[Length(Path)] <> '\' then
begin
Assign(F, Path);
GetFAttr(F, Attr);
if (DosError = 0) and (Attr and Directory <> 0) then
Path := Path + '\';
end;
FSplit(Path, D, N, E);
if N = '' then N := '*';
if E = '' then E := '.*';
Path := D + N + E;
end;
procedure FindFiles;
var
F: SearchRec;
begin
Count := 0;
FindFirst(Path, ReadOnly + Directory + Archive, F);
while (DosError = 0) and (Count < MaxDirSize) do
begin
GetMem(Dir[Count], Length(F.Name) + 10);
Move(F.Attr, Dir[Count]^, Length(F.Name) + 10);
Inc(Count);
FindNext(F);
end;
end;
procedure SortFiles;
begin
if (Count <> 0) and (@Less <> nil) then
QuickSort(0, Count - 1);
end;
procedure PrintFiles;
var
I, P: Integer;
Total: Longint;
T: DateTime;
N: NameStr;
E: ExtStr;
begin
WriteLn('Directory of ', Path);
if Count = 0 then
begin
WriteLn('No matching files');
Exit;
end;
Total := 0;
for I := 0 to Count-1 do
with Dir[I]^ do
begin
P := Pos('.', Name);
if P > 1 then
begin
N := Copy(Name, 1, P - 1);
E := Copy(Name, P + 1, 3);
end else
begin
N := Name;
E := '';
end;
Write(N, ' ': 9 - Length(N), E, ' ': 4 - Length(E));
if WideDir then
begin
if Attr and Directory <> 0 then
Write(' DIR')
else
Write((Size + 1023) shr 10: 3, 'k');
if I and 3 <> 3 then
Write(' ': 3)
else
WriteLn;
end else
begin
if Attr and Directory <> 0 then
Write('<DIR> ')
else
Write(Size: 8);
UnpackTime(Time, T);
WriteLn(T.Day: 4, '-',
MonthStr[T.Month], '-',
NumStr(T.Year mod 100, 2),
T.Hour: 4, ':',
NumStr(T.Min, 2));
end;
Inc(Total, Size);
end;
if WideDir and (Count and 3 <> 0) then WriteLn;
WriteLn(Count, ' files, ', Total, ' bytes, ',
DiskFree(Ord(Path[1])-64), ' bytes free');
end;
begin
GetCommand;
FindFiles;
SortFiles;
PrintFiles;
end.


27
Borland Turbo Pascal v55/DISPLAY.PAS Normal file
View File

@ -0,0 +1,27 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
unit Display;
{ Sample unit for CIRCULAR.PAS }
interface
procedure WriteXY(x, y : integer; s : string);
implementation
uses
Crt, Error;
procedure WriteXY(x, y : integer; s : string);
begin
if (x in [1..80]) and (y in [1..25]) then
begin
GoToXY(x, y);
Write(s);
end
else
ShowError('Invalid WriteXY coordinates');
end;
end.


95
Borland Turbo Pascal v55/DOC/CRT.DOC Normal file
View File

@ -0,0 +1,95 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 5.5 }
{ CRT Interface Unit }
{ }
{ Copyright (C) 1987, 1989 Borland International }
{ }
{*******************************************************}
unit Crt;
{$D-,I-,S-}
interface
const
{ CRT modes }
BW40 = 0; { 40x25 B/W on Color Adapter }
CO40 = 1; { 40x25 Color on Color Adapter }
BW80 = 2; { 80x25 B/W on Color Adapter }
CO80 = 3; { 80x25 Color on Color Adapter }
Mono = 7; { 80x25 on Monochrome Adapter }
Font8x8 = 256; { Add-in for ROM font }
{ Mode constants for 3.0 compatibility }
C40 = CO40;
C80 = CO80;
{ Foreground and background color constants }
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
{ Foreground color constants }
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{ Add-in for blinking }
Blink = 128;
var
{ Interface variables }
CheckBreak: Boolean; { Enable Ctrl-Break }
CheckEOF: Boolean; { Enable Ctrl-Z }
DirectVideo: Boolean; { Enable direct video addressing }
CheckSnow: Boolean; { Enable snow filtering }
LastMode: Word; { Current text mode }
TextAttr: Byte; { Current text attribute }
WindMin: Word; { Window upper left coordinates }
WindMax: Word; { Window lower right coordinates }
{ Interface procedures }
procedure AssignCrt(var F: Text);
function KeyPressed: Boolean;
function ReadKey: Char;
procedure TextMode(Mode: Integer);
procedure Window(X1,Y1,X2,Y2: Byte);
procedure GotoXY(X,Y: Byte);
function WhereX: Byte;
function WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(MS: Word);
procedure Sound(Hz: Word);
procedure NoSound;


152
Borland Turbo Pascal v55/DOC/DOS.DOC Normal file
View File

@ -0,0 +1,152 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 5.5 }
{ DOS Interface Unit }
{ }
{ Copyright (C) 1987, 1989 Borland International }
{ }
{*******************************************************}
unit Dos;
{$D-,I-,S-}
interface
const
{ Flags bit masks }
FCarry = $0001;
FParity = $0004;
FAuxiliary = $0010;
FZero = $0040;
FSign = $0080;
FOverflow = $0800;
{ File mode magic numbers }
fmClosed = $D7B0;
fmInput = $D7B1;
fmOutput = $D7B2;
fmInOut = $D7B3;
{ File attribute constants }
ReadOnly = $01;
Hidden = $02;
SysFile = $04;
VolumeID = $08;
Directory = $10;
Archive = $20;
AnyFile = $3F;
type
{ String types }
ComStr = string[127]; { Command line string }
PathStr = string[79]; { Full file path string }
DirStr = string[67]; { Drive and directory string }
NameStr = string[8]; { File name string }
ExtStr = string[4]; { File extension string }
{ Registers record used by Intr and MsDos }
Registers = record
case Integer of
0: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Word);
1: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
end;
{ Typed-file and untyped-file record }
FileRec = record
Handle: Word;
Mode: Word;
RecSize: Word;
Private: array[1..26] of Byte;
UserData: array[1..16] of Byte;
Name: array[0..79] of Char;
end;
{ Textfile record }
TextBuf = array[0..127] of Char;
TextRec = record
Handle: Word;
Mode: Word;
BufSize: Word;
Private: Word;
BufPos: Word;
BufEnd: Word;
BufPtr: ^TextBuf;
OpenFunc: Pointer;
InOutFunc: Pointer;
FlushFunc: Pointer;
CloseFunc: Pointer;
UserData: array[1..16] of Byte;
Name: array[0..79] of Char;
Buffer: TextBuf;
end;
{ Search record used by FindFirst and FindNext }
SearchRec = record
Fill: array[1..21] of Byte;
Attr: Byte;
Time: Longint;
Size: Longint;
Name: string[12];
end;
{ Date and time record used by PackTime and UnpackTime }
DateTime = record
Year,Month,Day,Hour,Min,Sec: Word;
end;
var
{ Error status variable }
DosError: Integer;
function DosVersion: Word;
procedure Intr(IntNo: Byte; var Regs: Registers);
procedure MsDos(var Regs: Registers);
procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
procedure SetDate(Year,Month,Day: Word);
procedure GetTime(var Hour,Minute,Second,Sec100: Word);
procedure SetTime(Hour,Minute,Second,Sec100: Word);
procedure GetCBreak(var Break: Boolean);
procedure SetCBreak(Break: Boolean);
procedure GetVerify(var Verify: Boolean);
procedure SetVerify(Verify: Boolean);
function DiskFree(Drive: Byte): Longint;
function DiskSize(Drive: Byte): Longint;
procedure GetFAttr(var F; var Attr: Word);
procedure SetFAttr(var F; Attr: Word);
procedure GetFTime(var F; var Time: Longint);
procedure SetFTime(var F; Time: Longint);
procedure FindFirst(Path: PathStr; Attr: Word; var F: SearchRec);
procedure FindNext(var F: SearchRec);
procedure UnpackTime(P: Longint; var T: DateTime);
procedure PackTime(var T: DateTime; var P: Longint);
procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
procedure SetIntVec(IntNo: Byte; Vector: Pointer);
procedure SwapVectors;
procedure Keep(ExitCode: Word);
procedure Exec(Path: PathStr; ComLine: ComStr);
function DosExitCode: Word;
function FSearch(Path: PathStr; DirList: String): PathStr;
function FExpand(Path: PathStr): PathStr;
procedure FSplit(Path: PathStr; var Dir: DirStr;
var Name: NameStr; var Ext: ExtStr);
function EnvCount: Integer;
function EnvStr(Index: Integer): String;
function GetEnv(EnvVar: String): String;


338
Borland Turbo Pascal v55/DOC/GRAPH.DOC Normal file
View File

@ -0,0 +1,338 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 5.5 }
{ Graph Interface Unit }
{ }
{ Copyright (C) 1987,89 Borland International }
{ }
{*******************************************************}
unit Graph;
interface
const
{ GraphResult error return codes: }
grOk = 0;
grNoInitGraph = -1;
grNotDetected = -2;
grFileNotFound = -3;
grInvalidDriver = -4;
grNoLoadMem = -5;
grNoScanMem = -6;
grNoFloodMem = -7;
grFontNotFound = -8;
grNoFontMem = -9;
grInvalidMode = -10;
grError = -11; { generic error }
grIOerror = -12;
grInvalidFont = -13;
grInvalidFontNum = -14;
{ define graphics drivers }
CurrentDriver = -128; { passed to GetModeRange }
Detect = 0; { requests autodetection }
CGA = 1;
MCGA = 2;
EGA = 3;
EGA64 = 4;
EGAMono = 5;
IBM8514 = 6;
HercMono = 7;
ATT400 = 8;
VGA = 9;
PC3270 = 10;
{ graphics modes for each driver }
CGAC0 = 0; { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
CGAC1 = 1; { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
CGAC2 = 2; { 320x200 palette 2: Green, Red, Brown; 1 page }
CGAC3 = 3; { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
CGAHi = 4; { 640x200 1 page }
MCGAC0 = 0; { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
MCGAC1 = 1; { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
MCGAC2 = 2; { 320x200 palette 2: Green, Red, Brown; 1 page }
MCGAC3 = 3; { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
MCGAMed = 4; { 640x200 1 page }
MCGAHi = 5; { 640x480 1 page }
EGALo = 0; { 640x200 16 color 4 page }
EGAHi = 1; { 640x350 16 color 2 page }
EGA64Lo = 0; { 640x200 16 color 1 page }
EGA64Hi = 1; { 640x350 4 color 1 page }
EGAMonoHi = 3; { 640x350 64K on card, 1 page; 256K on card, 2 page }
HercMonoHi = 0; { 720x348 2 page }
ATT400C0 = 0; { 320x200 palette 0: LightGreen, LightRed, Yellow; 1 page }
ATT400C1 = 1; { 320x200 palette 1: LightCyan, LightMagenta, White; 1 page }
ATT400C2 = 2; { 320x200 palette 2: Green, Red, Brown; 1 page }
ATT400C3 = 3; { 320x200 palette 3: Cyan, Magenta, LightGray; 1 page }
ATT400Med = 4; { 640x200 1 page }
ATT400Hi = 5; { 640x400 1 page }
VGALo = 0; { 640x200 16 color 4 page }
VGAMed = 1; { 640x350 16 color 2 page }
VGAHi = 2; { 640x480 16 color 1 page }
PC3270Hi = 0; { 720x350 1 page }
IBM8514LO = 0; { 640x480 256 colors }
IBM8514HI = 1; { 1024x768 256 colors }
{ Colors for SetPalette and SetAllPalette: }
Black = 0;
Blue = 1;
Green = 2;
Cyan = 3;
Red = 4;
Magenta = 5;
Brown = 6;
LightGray = 7;
DarkGray = 8;
LightBlue = 9;
LightGreen = 10;
LightCyan = 11;
LightRed = 12;
LightMagenta = 13;
Yellow = 14;
White = 15;
{ colors for 8514 to set standard EGA colors w/o knowing their values }
EGABlack = 0; { dark colors }
EGABlue = 1;
EGAGreen = 2;
EGACyan = 3;
EGARed = 4;
EGAMagenta = 5;
EGABrown = 20;
EGALightgray = 7;
EGADarkgray = 56; { light colors }
EGALightblue = 57;
EGALightgreen = 58;
EGALightcyan = 59;
EGALightred = 60;
EGALightmagenta = 61;
EGAYellow = 62;
EGAWhite = 63;
{ Line styles and widths for Get/SetLineStyle: }
SolidLn = 0;
DottedLn = 1;
CenterLn = 2;
DashedLn = 3;
UserBitLn = 4; { User-defined line style }
NormWidth = 1;
ThickWidth = 3;
{ Set/GetTextStyle constants: }
DefaultFont = 0; { 8x8 bit mapped font }
TriplexFont = 1; { "Stroked" fonts }
SmallFont = 2;
SansSerifFont = 3;
GothicFont = 4;
HorizDir = 0; { left to right }
VertDir = 1; { bottom to top }
UserCharSize = 0; { user-defined char size }
{ Clipping constants: }
ClipOn = true;
ClipOff = false;
{ Bar3D constants: }
TopOn = true;
TopOff = false;
{ Fill patterns for Get/SetFillStyle: }
EmptyFill = 0; { fills area in background color }
SolidFill = 1; { fills area in solid fill color }
LineFill = 2; { --- fill }
LtSlashFill = 3; { /// fill }
SlashFill = 4; { /// fill with thick lines }
BkSlashFill = 5; { \\\ fill with thick lines }
LtBkSlashFill = 6; { \\\ fill }
HatchFill = 7; { light hatch fill }
XHatchFill = 8; { heavy cross hatch fill }
InterleaveFill = 9; { interleaving line fill }
WideDotFill = 10; { Widely spaced dot fill }
CloseDotFill = 11; { Closely spaced dot fill }
UserFill = 12; { user defined fill }
{ BitBlt operators for PutImage: }
NormalPut = 0; { MOV } { left for 1.0 compatibility }
CopyPut = 0; { MOV }
XORPut = 1; { XOR }
OrPut = 2; { OR }
AndPut = 3; { AND }
NotPut = 4; { NOT }
{ Horizontal and vertical justification for SetTextJustify: }
LeftText = 0;
CenterText = 1;
RightText = 2;
BottomText = 0;
{ CenterText = 1; already defined above }
TopText = 2;
const
MaxColors = 15;
type
PaletteType = record
Size : byte;
Colors : array[0..MaxColors] of shortint;
end;
LineSettingsType = record
LineStyle : word;
Pattern : word;
Thickness : word;
end;
TextSettingsType = record
Font : word;
Direction : word;
CharSize : word;
Horiz : word;
Vert : word;
end;
FillSettingsType = record { Pre-defined fill style }
Pattern : word;
Color : word;
end;
FillPatternType = array[1..8] of byte; { User defined fill style }
PointType = record
X, Y : integer;
end;
ViewPortType = record
x1, y1, x2, y2 : integer;
Clip : boolean;
end;
ArcCoordsType = record
X, Y : integer;
Xstart, Ystart : integer;
Xend, Yend : integer;
end;
var
GraphGetMemPtr : Pointer; { allows user to steal heap allocation }
GraphFreeMemPtr : Pointer; { allows user to steal heap de-allocation }
{ *** high-level error handling *** }
function GraphErrorMsg(ErrorCode : integer) : String;
function GraphResult : integer;
{ *** detection, initialization and crt mode routines *** }
procedure DetectGraph(var GraphDriver, GraphMode : integer);
function GetDriverName : string;
procedure InitGraph(var GraphDriver : integer;
var GraphMode : integer;
PathToDriver : String);
function RegisterBGIfont(Font : pointer) : integer;
function RegisterBGIdriver(Driver : pointer) : integer;
function InstallUserDriver(DriverFileName : string;
AutoDetectPtr : pointer) : integer;
function InstallUserFont(FontFileName : string) : integer;
procedure SetGraphBufSize(BufSize : word);
function GetMaxMode : integer;
procedure GetModeRange(GraphDriver : integer; var LoMode, HiMode : integer);
function GetModeName(GraphMode : integer) : string;
procedure SetGraphMode(Mode : integer);
function GetGraphMode : integer;
procedure GraphDefaults;
procedure RestoreCrtMode;
procedure CloseGraph;
function GetX : integer;
function GetY : integer;
function GetMaxX : integer;
function GetMaxY : integer;
{ *** Screen, viewport, page routines *** }
procedure ClearDevice;
procedure SetViewPort(x1, y1, x2, y2 : integer; Clip : boolean);
procedure GetViewSettings(var ViewPort : ViewPortType);
procedure ClearViewPort;
procedure SetVisualPage(Page : word);
procedure SetActivePage(Page : word);
{ *** point-oriented routines *** }
procedure PutPixel(X, Y : integer; Pixel : word);
function GetPixel(X, Y : integer) : word;
{ *** line-oriented routines *** }
procedure SetWriteMode(WriteMode : integer);
procedure LineTo(X, Y : integer);
procedure LineRel(Dx, Dy : integer);
procedure MoveTo(X, Y : integer);
procedure MoveRel(Dx, Dy : integer);
procedure Line(x1, y1, x2, y2 : integer);
procedure GetLineSettings(var LineInfo : LineSettingsType);
procedure SetLineStyle(LineStyle : word;
Pattern : word;
Thickness : word);
{ *** polygon, fills and figures *** }
procedure Rectangle(x1, y1, x2, y2 : integer);
procedure Bar(x1, y1, x2, y2 : integer);
procedure Bar3D(x1, y1, x2, y2 : integer; Depth : word; Top : boolean);
procedure DrawPoly(NumPoints : word; var PolyPoints);
procedure FillPoly(NumPoints : word; var PolyPoints);
procedure GetFillSettings(var FillInfo : FillSettingsType);
procedure GetFillPattern(var FillPattern : FillPatternType);
procedure SetFillStyle(Pattern : word; Color : word);
procedure SetFillPattern(Pattern : FillPatternType; Color : word);
procedure FloodFill(X, Y : integer; Border : word);
{ *** arc, circle, and other curves *** }
procedure Arc(X, Y : integer; StAngle, EndAngle, Radius : word);
procedure GetArcCoords(var ArcCoords : ArcCoordsType);
procedure Circle(X, Y : integer; Radius : word);
procedure Ellipse(X, Y : integer;
StAngle, EndAngle : word;
XRadius, YRadius : word);
procedure FillEllipse(X, Y : integer;
XRadius, YRadius : word);
procedure GetAspectRatio(var Xasp, Yasp : word);
procedure SetAspectRatio(Xasp, Yasp : word);
procedure PieSlice(X, Y : integer; StAngle, EndAngle, Radius : word);
procedure Sector(X, Y : Integer;
StAngle, EndAngle,
XRadius, YRadius : word);
{ *** color and palette routines *** }
procedure SetBkColor(ColorNum : word);
procedure SetColor(Color : word);
function GetBkColor : word;
function GetColor : word;
procedure SetAllPalette(var Palette);
procedure SetPalette(ColorNum : word; Color : shortint);
procedure GetPalette(var Palette : PaletteType);
function GetPaletteSize : integer;
procedure GetDefaultPalette(var Palette : PaletteType);
function GetMaxColor : word;
procedure SetRGBPalette(ColorNum, RedValue, GreenValue, BlueValue : integer);
{ *** bit-image routines *** }
function ImageSize(x1, y1, x2, y2 : integer) : word;
procedure GetImage(x1, y1, x2, y2 : integer; var BitMap);
procedure PutImage(X, Y : integer; var BitMap; BitBlt : word);
{ *** text routines *** }
procedure GetTextSettings(var TextInfo : TextSettingsType);
procedure OutText(TextString : string);
procedure OutTextXY(X, Y : integer; TextString : string);
procedure SetTextJustify(Horiz, Vert : word);
procedure SetTextStyle(Font, Direction : word; CharSize : word);
procedure SetUserCharSize(MultX, DivX, MultY, DivY : word);
function TextHeight(TextString : string) : word;
function TextWidth(TextString : string) : word;


66
Borland Turbo Pascal v55/DOC/GRAPH3.DOC Normal file
View File

@ -0,0 +1,66 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 5.5 }
{ 3.0 Graphics Compatibility Unit }
{ }
{ Copyright (C) 1987,1989 Borland International }
{ }
{*******************************************************}
unit Graph3;
{$D-,I-,S-}
interface
uses Crt;
const
North = 0;
East = 90;
South = 180;
West = 270;
procedure GraphMode;
procedure GraphColorMode;
procedure HiRes;
procedure HiResColor(Color: Integer);
procedure Palette(N: Integer);
procedure GraphBackground(Color: Integer);
procedure GraphWindow(X1,Y1,X2,Y2: Integer);
procedure Plot(X,Y,Color: Integer);
procedure Draw(X1,Y1,X2,Y2,Color: Integer);
procedure ColorTable(C1,C2,C3,C4: Integer);
procedure Arc(X,Y,Angle,Radius,Color: Integer);
procedure Circle(X,Y,Radius,Color: Integer);
procedure GetPic(var Buffer; X1,Y1,X2,Y2: Integer);
procedure PutPic(var Buffer; X,Y: Integer);
function GetDotColor(X,Y: Integer): Integer;
procedure FillScreen(Color: Integer);
procedure FillShape(X,Y,FillCol,BorderCol: Integer);
procedure FillPattern(X1,Y1,X2,Y2,Color: Integer);
procedure Pattern(var P);
procedure Back(Dist: Integer);
procedure ClearScreen;
procedure Forwd(Dist: Integer);
function Heading: Integer;
procedure HideTurtle;
procedure Home;
procedure NoWrap;
procedure PenDown;
procedure PenUp;
procedure SetHeading(Angle: Integer);
procedure SetPenColor(Color: Integer);
procedure SetPosition(X,Y: Integer);
procedure ShowTurtle;
procedure TurnLeft(Angle: Integer);
procedure TurnRight(Angle: Integer);
procedure TurtleDelay(Delay: integer);
procedure TurtleWindow(X,Y,W,H: Integer);
function TurtleThere: Boolean;
procedure Wrap;
function Xcor: Integer;
function Ycor: Integer;


454
Borland Turbo Pascal v55/DOC/HELPME!.DOC Normal file
View File

@ -0,0 +1,454 @@
TURBO PASCAL 5.5: ANSWERS TO COMMON QUESTIONS
---------------------------------------------
1. Can I build programs bigger than 64K?
The total size of a program's code is only limited by the
memory you have available; but each unit (module) can be
no larger than 64K, since it has to have its own code
segment.
The data segment is still no more than 64K, but the heap
is unlimited just as in 3.0. In fact, we've rewritten the
heap manager to make it much more efficient. There's no
waste when allocating memory (in 3.0, all blocks were
rounded up to a factor of 8), and you can install a heap
error routine that gets called if an allocation request
fails. All in all, 5.5's heap manager is much faster than
version 3.0.
2. Can Turbo Pascal run on generic MS-DOS machines?
TPC.EXE will run on generic machines when you use the /Q
option. The System, Overlay, Dos, and Printer standard
units will operate correctly on MS-DOS generic machines.
Generated .EXE's are MS-DOS compatible as long as you
don't use the special PC units (such as Crt, Graph, and
Graph3).
3. Does Turbo Pascal 5.5 support large integers?
Yes, TP 5.5 has virtually every incarnation of 8-, 16-, and
32-bit integers: shortint, integer, longint, byte, and
word.
4. Will the toolboxes for 4.0 work with 5.5?
Yes, all 4.0 versions of the toolboxes will work with
Turbo Pascal 5.5. In a few cases, minor changes to
compiler directives are recommended. Refer to the Turbo
Pascal README file for more information.
5. Does Turbo Pascal version 5.5 support conditional
compilation?
Yes, Turbo 5.5 includes conditional compilation support.
You use {$DEFINE ...} and {$UNDEF ...} for symbols and
{$IFDEF ...}. Using the {$IFOPT ...} conditional
directive, you can even test the settings of compiler
directives like R-, N+, and others. For the command-line
compiler, you can define symbols with the /D directive. In
the integrated compiler, you can also define symbols via
the Options/Compiler/Conditional Defines menu command.
6. How much of the 64K in the data segment is actually
available to my program?
The amount of data segment used by the run-time library
depends on which standard units you use in your program.
Here is the data segment usage (in bytes) for each unit:
UNIT Data Size
---- ---------
System 664
Overlay 24
Crt 20
Dos 6
Printer 256
Graph 1070
Turbo3 256
Graph3 0
=========
2282
The total size of the data segment is 65,520 bytes. If you
used only the System unit, the amount of data segment
space left over would be
65520 - 664 = 64856 bytes
7. What is the largest global data structure you can
allocate?
The maximum size of a single variable that can be
allocated on the heap is 65,521 bytes.
8. How do I find out how much code and data were generated by
the compiler for a program or unit?
If you are using the integrated environment, build your
program or unit and then use the Get Info command in the
Compile menu. This will bring up a window of information
that includes the size of code and data.
If you are using the command-line compiler, the size of
generated code and data is displayed on the screen at the
end of compilation.
9. Are the .OBJ files generated by Turbo C and Turbo
Assembler compatible with 5.5?
You can write Turbo C or Turbo Assembler routines and link
the .OBJ files into your Turbo Pascal programs by using
{$L} compiler directives. Turbo Pascal 5.5 generates .TPU
(Turbo Pascal Unit) files, not .OBJ files. We've made that
decision for many reasons:
A. TP 5.5's .TPU files are smaller than .OBJ's, and they
contain symbolic information important to the support
of Pascal's strict type conventions (types, constants,
etc.).
B. .TPU files allow "smart linking" - elimination of
unused code and data on a procedure-by-procedure
basis.
C. .TPU's allow built-in project management through
version 5.5's Make and Build commands.
D. .TPU's allow faster compilation speeds (34,000 lines
per minute on a PS/2 Model 60).
10. Will the $L compiler directive work for compiler object files
other than assembler?
That depends on the language. TURBO requires all the code
in the .OBJ to be in *one* CODE segment, and all the data
to be in *one* DATA segment. With assembly language that's
easy, but it may not work with some high-level language
compilers. You can use Turbo C to generate .OBJ files for
use by Turbo Pascal programs. An example, CPASDEMO.PAS is
included on the distribution disks.
11. Does the built-in linker eliminate unused data?
Yes. Unused code AND data are stripped when you compile to
disk.
12. If two units use a third unit, does the third unit get
included twice in my program?
No. All your units are "linked" together when you compile
your program. Only one copy of each procedure and function
used is generated. There is NO duplication of run-time
code. In fact, Turbo Pascal 5.5 has "smart linking," which
eliminates any unused code and data from the final .EXE.
13. What happens if you attempt to link another unit in which the
compiler directives are set differently?
Compiler directives are local to the unit they are
declared in. Thus, the compiler directives in one unit, or
in the main program, have no effect on the directives set
in another unit.
14. Can I create my own .TPL file?
Yes, but Turbo Pascal will only use the TURBO.TPL library
file. If you want to add your own units to the TURBO.TPL
file, you can use the unit mover program (TPUMOVER.EXE).
For example, you might want a customized version of
TURBO.TPL for each of the programs you're developing. A
corresponding configuration file for Turbo Pascal would
specify a different Turbo directory and thus fetch the
appropriate .TPL file for each of your projects.
15. What rules should I follow when writing an interrupt
handler?
The following is a list of rules to keep in mind when
writing an interrupt handler:
A. Use GetIntVec and SetIntVec to install/uninstall
interrupt handlers
B. Use the interrupt directive
C. Be careful about reentrancy. Don't use any calls to
DOS or to Turbo Pascal's overlay or heap management
routines in your interrupt handler
D. Interrupt procedures and functions must use the far
call model (use the {$F+} option)
E. Be proficient with the BIOS and assembly language
before attempting to write an interrupt handler
F. Make sure your interrupt handler is not in an
overlaid unit.
G. Neither static nor virtual methods can be used as
interrupt handlers.
16. Does a procedure or function in a program have to be of a
near or far call model?
If you are using overlays or procedural variables, you
should probably turn {$F+} on for all units and the main
program (the extra overhead of always using far calls is
usually quite small).
Otherwise, Turbo Pascal automatically selects the correct
call model. A routine is always a near call model unless
1) It is declared in the interface section of a unit
2) You override the default call model by using the {$F+}
compiler option
3) It is an object method. Methods are always far calls.
You should also use the {$F+} option to override the
default call model if you are writing interrupt handlers,
error handlers, exit procedures, or procedures or
functions that will be called via a procedural variable.
17. How do I write reentrant code in Turbo Pascal?
If a routine follows these rules, it is reentrant:
A. All data is allocated on the stack.
B. The routine doesn't use any global variables.
C. The routine can be interrupted at any time without
affecting the execution of the routine.
D. The routine doesn't call any other routines that are
not reentrant (e.g., DOS I/O).
18. What is the best approach to taking advantage of the new IEEE
floating-point types?
The new IEEE floating-point types are available when you
compile your program with {$N+} and you have a math
coprocessor; they are also available if you don't have a
coprocessor, but specify {N+,E+}. The 8087 emulator has
greater precision, but is significantly slower than the
fast, 6-byte, software-only reals. When developing
programs that will be compiled and run on machines without
the 8087 coprocessor, consider the trade-offs of speed
(built-in reals) vs. precision (8087 hardware/emulation)
and make the appropriate choice.
19. What type is Comp? What is it useful for?
The Comp type is a cross between an integer and a real
type and is available when 8087 code is generated {$N+}.
If no math coprocessor is available, specify {$N+,E+} and
the emulator will support the Comp type.
The compiler treats it as a real type without an exponent.
Thus Comp is useful when you need to store extremely large
numbers but don't need a decimal point. For example, you
might use variables of type Comp to store amounts in cents
and divide the value of the variable by 100 to determine
what the value in dollars and cents would be.
20. How many significant digits do the 8087 floating-point types
provide?
Type Digits of precision
-------- -------------------
single 7-8
double 15-16
extended 19-20
comp 19-20
21. Are the intermediate results of real number expressions
stored in the 8087 registers?
No. The user (8086) stack is used to store intermediate
results of real number expressions.
22. How does rounding work with IEEE floating point?
The 8087 math coprocessor uses a different method for
rounding numbers than what you may be used to. In order to
achieve a more even distribution of values, the 8087 uses
a method sometimes called "Banker's Rounding." This method
dictates that a number will always be rounded to the
nearest EVEN number. Note that this is quite different
than always rounding UP. Here are a couple of examples:
Round(0.5) = 0
Round(1.5) = 2
23. How do you do I/O redirection?
If you want to do DOS I/O redirection when running an .EXE
file generated by Turbo Pascal, DON'T use the Crt unit. If
you do, make sure you assign a null file name to the
standard Output file handle:
Assign(Output, ''); { Assign a null file name Output }
ReWrite(Output); { Open the file for output }
Any Write statement that does not specify a file variable
will be redirected to the DOS standard output file.
24. How do you go about upgrading version 3.0 programs with
lots of chain files?
Chaining is not possible with .EXE files. Control can be
passed to another program by use of the EXEC procedure in
the DOS unit. You can also use 5.5's overlay manager to
build very large programs.
25. Are overlays supported in 5.5?
Yes! See the example program OVRDEMO.PAS and refer to the
Turbo Pascal manual for information on overlays.
26. Is there any support in Turbo Pascal 5.5 for file and record
locking?
There's a standard variable in the System unit called
FileMode, which you can use to assign an open mode for use
in all subsequent Resets. There are no record-locking
routines implemented in the standard version, but they are
easily implemented through MsDos calls.
27. Does Turbo 5.5 support procedural parameters?
Yes. See PROCVAR.PAS, DIRDEMO.PAS, and refer to the
Reference Guide for a complete description.
28. Can you use identifiers other than scalar in the case statement?
Case statements allow the following ordinal types:
Char, Boolean, ShortInt, Byte, Integer, Word, and
user-defined enumeration.
29. Is the run-time license policy the same as in version 3.0?
YES, there are no royalties!
30. C has static variables, is there anything similar in 5.5?
You can declare private global variables in the
implementation part of a unit. Such variables are only
visible within that unit. Like other globals, they retain
their values across calls.
Typed constant declarations declared within a procedure or
function also behave exactly like C's static variables.
They are local in scope but since they are allocated in
the data segment, they retain their values from call to
call.
31. What Turbo Pascal 3.0 code will cause the most problems
converting to version 5.5?
With our UPGRADE program (see appropriate Appendix in your
manual), it's not very difficult to port your code to 5.5.
It depends a lot on the type of programs you write.
The passing of parameters on the stack is done much more
efficiently now, so changes will have to be made to inline
machine code and assembly language. Most of the changes
are optional: using new types, breaking your program into
modules to take advantage of separate compilation. (The
UPGRADE program has a special option to help you "unitize"
your program too. It does all the "typing" for you.)
Some stricter type-checking is performed in version 5.5.
For example, the Dos unit now defines the often-seen
registers record type (AX, BX...); MsDos and Intr now take
this type. In this case, you can type-cast or change the
type identifier and recompile.
32. What books can I read that will help me with Turbo Pascal
5.5?
The Turbo Pascal Tutor is an excellent reference to Turbo
Pascal. Also, Osborne/McGraw Hill has a line of books
about Borland's products.
33. How do I use .BIN files provided by third-party vendors with
5.5?
We've included a utility on your distribution disk called
BINOBJ.EXE, which converts binary files into .OBJ files
that are linkable to your Turbo Pascal 5.5 programs. In
general this will only work if the binary files contain
data, not code. Contact your third-party vendor to see if
they also provide .OBJ versions of their programs.
34. Why does TURBO sometimes try to read from another drive
when I run it?
When you leave Turbo Pascal, it saves the name and path of
the file you were last editing in a pick list. The next
time you load Turbo, it checks this pick list and tries to
load the file you were last editing. If the file you were
last editing was in another drive, Turbo will try to read
from that drive. This also occurs if you have installed
another drive as your Turbo Directory.
35. Does Turbo Pascal 5.5 support EMS?
Yes, Turbo Pascal 5.5 will use up to 64K of EMS for
storing the edit buffer. In addition, you can instruct the
Overlay unit to place your overlaid units in EMS. Finally,
EMS.PAS on the distribution disk shows you how to access
EMS memory from a Turbo Pascal program.
36. How can I allocate my own I/O buffer for a text file?
You can use the procedure SetTextBuf to allocate your own
text file buffer either in the data segment or on the
heap.
37. Why aren't the new settings used after I install TURBO.EXE
using the TINST.EXE program?
You probably have a .TP file in the current or Turbo
directory being loaded and the settings in the .TP file
override the settings installed by TINST. Delete the .TP
file.
38. What is the largest string supported?
A string can be 255 characters long. You can write your
own routines to handle strings with lengths greater than
255 characters.
39. Can I still write to file 'Con' without changes?
The 'Con' file is no longer supported, but you can still
write to the screen with a simple Write with no file
variable. The file system has been completely redesigned
to allow you to write your own text file device drivers.
With these, you can implement a Pascal-like text-file
interface to any device, such as serial ports, windowing
systems, memory, etc.
40. What is constant merging?
For example, when you use the same string constant more
than once in a program block, the compiler only saves one
copy of this string. In the generated program, a pointer
is created that references the one copy of this string in
the generated .EXE file.
41. Have Turbo Pascal 3.0 run-time error codes changed in
Turbo Pascal 5.5?
Yes, error codes have changed; refer to Appendix I in the
Reference Guide. The Turbo3 unit contains a version 3.0
compatible IOResult function.


47
Borland Turbo Pascal v55/DOC/OVERLAY.DOC Normal file
View File

@ -0,0 +1,47 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 5.5 }
{ Overlay Interface Unit }
{ }
{ Copyright (C) 1987, 1989 Borland International }
{ }
{*******************************************************}
unit Overlay;
{$D-,I-,S-}
interface
const
ovrOk = 0;
ovrError = -1;
ovrNotFound = -2;
ovrNoMemory = -3;
ovrIOError = -4;
ovrNoEMSDriver = -5;
ovrNoEMSMemory = -6;
const
OvrResult: Integer = 0;
OvrTrapCount: Word = 0;
OvrLoadCount: Word = 0;
OvrFileMode: Byte = 0;
type
OvrReadFunc = function(OvrSeg: Word): Integer;
var
OvrReadBuf: OvrReadFunc;
procedure OvrInit(FileName: String);
procedure OvrInitEMS;
procedure OvrSetBuf(Size: LongInt);
function OvrGetBuf: LongInt;
procedure OvrSetRetry(Size: LongInt);
function OvrGetRetry: LongInt;
procedure OvrClearBuf;
implementation


19
Borland Turbo Pascal v55/DOC/PRINTER.DOC Normal file
View File

@ -0,0 +1,19 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 5.5 }
{ Printer Interface Unit }
{ }
{ Copyright (C) 1987, 1989 Borland International }
{ }
{*******************************************************}
unit Printer;
{$D-,I-,S-}
interface
var
Lst: Text;


61
Borland Turbo Pascal v55/DOC/SYSTEM.DOC Normal file
View File

@ -0,0 +1,61 @@
{*******************************************************}
{ }
{ Turbo Pascal Runtime Library Version 5.5 }
{ System Unit }
{ }
{ Copyright (C) 1987, 1989 Borland International }
{ }
{*******************************************************}
unit System;
interface
const
OvrCodeList: Word = 0; { Overlay code segment list }
OvrHeapSize: Word = 0; { Initial overlay buffer size }
OvrDebugPtr: Pointer = nil; { Overlay debugger hook }
OvrHeapOrg: Word = 0; { Overlay buffer origin }
OvrHeapPtr: Word = 0; { Overlay buffer pointer }
OvrHeapEnd: Word = 0; { Overlay buffer end }
OvrLoadList: Word = 0; { Loaded overlays list }
OvrDosHandle: Word = 0; { Overlay DOS handle }
OvrEmsHandle: Word = 0; { Overlay EMS handle }
HeapOrg: Pointer = nil; { Heap origin }
HeapPtr: Pointer = nil; { Heap pointer }
FreePtr: Pointer = nil; { Free list pointer }
FreeMin: Word = 0; { Minimum free list size }
HeapError: Pointer = nil; { Heap error function }
ExitProc: Pointer = nil; { Exit procedure }
ExitCode: Integer = 0; { Exit code }
ErrorAddr: Pointer = nil; { Runtime error address }
PrefixSeg: Word = 0; { Program segment prefix }
StackLimit: Word = 0; { Stack pointer low limit }
InOutRes: Integer = 0; { I/O result buffer }
RandSeed: Longint = 0; { Random seed }
FileMode: Byte = 2; { File open mode }
Test8087: Byte = 0; { 8087 test result }
var
Input: Text; { Input standard file }
Output: Text; { Output standard file }
SaveInt00: Pointer; { Saved interrupt $00 }
SaveInt02: Pointer; { Saved interrupt $02 }
SaveInt1B: Pointer; { Saved interrupt $1B }
SaveInt23: Pointer; { Saved interrupt $23 }
SaveInt24: Pointer; { Saved interrupt $24 }
SaveInt34: Pointer; { Saved interrupt $34 }
SaveInt35: Pointer; { Saved interrupt $35 }
SaveInt36: Pointer; { Saved interrupt $36 }
SaveInt37: Pointer; { Saved interrupt $37 }
SaveInt38: Pointer; { Saved interrupt $38 }
SaveInt39: Pointer; { Saved interrupt $39 }
SaveInt3A: Pointer; { Saved interrupt $3A }
SaveInt3B: Pointer; { Saved interrupt $3B }
SaveInt3C: Pointer; { Saved interrupt $3C }
SaveInt3D: Pointer; { Saved interrupt $3D }
SaveInt3E: Pointer; { Saved interrupt $3E }
SaveInt3F: Pointer; { Saved interrupt $3F }
SaveInt75: Pointer; { Saved interrupt $75 }


334
Borland Turbo Pascal v55/DOC/THELP.DOC Normal file
View File

@ -0,0 +1,334 @@
TURBO HELP UTILITY
------------------
This file explains how to use THELP.COM. THELP is a
memory-resident utility that provides online help for Turbo
Pascal and Turbo C. If you are using Turbo Debugger, for
example, you can load THELP, then run the debugger and get
online help for Pascal or C while you are debugging.
Table of Contents
-----------------
1. Starting THELP
2. Command-line Options Summary
3. Detailed Explanation of Keys Used When THELP is Active
4. Detailed Explanation of Command-line Options
1. Starting THELP
------------------
Load THELP at the DOS command-line simply by typing THELP.
Make sure the Turbo help file (TURBO.HLP for Turbo Pascal,
TCHELP.TCH for TURBO C) is in the current directory or use the /F
commandline option described below.
Memory Usage - THELP requires about 8K bytes (+ 32K swap file);
40K with no swapping.
Default hotkey - The default hotkey is Numeric-Keypad-5 (scan
code 4ch, shift state 00h).
Paste speed - The default pasting speed is FAST. You'll have
to experiment if it pastes too quickly for your
editor. Note that you should turn off autoindent
in the integrated environment before using the
paste feature (Ctrl-Q I toggles autoindent).
If you are using SideKick Plus or SideKick 1.x, make sure you
load THELP before you load SideKick.
2. Command-line Options Summary
-------------------------------
USAGE: THELP [options]
Here is a summary of the command line options. If you use more
than one option, they must be separated by spaces.
/B Use BIOS for video
/C#xx Select color: #=color number, xx=hex color value
/Dname Full path for disk swapping (implies /S1)
/Fname Full path and filename of help file
/H,/?,? Display this help screen
/Kxxyy Change hotkey: xx=shift state, yy=scan code
/Lxx Force number of rows on screen: xx=25,43,50
/M+,/M- Display help text: on monochrome screen(+),
on default screen(-)
/Px Pasting speed: 0=slow, 1=medium, 2=fast
/R Send options to resident THELP
/Sx Default Swapping Mode: 1=Use Disk, 2=Use EMS,
3=No Swapping
/U Remove THELP from memory
/W Write Options to THELP.COM and exit
3. Detailed Explanation of Keys Used When THELP is Active
---------------------------------------------------------
Arrow keys: Move the highlight from item to item within the
current help screen.
PgUp/PgDn: Move from screen to screen if additional screens
are available.
ENTER: Select help entry for the item highlighted in the
current help screen.
ESC: End Help.
F1: Help Index. F1 from any help screen brings up
the Help Index.
ALT-F1: Displays in reverse order the last 20 screens you
have reviewed.
CTL-F1: Bring up help screen for THELP's hot keys.
F key: Select new help file. 'F' or 'f' brings up a
window that allows you to change help files on the
fly. Type in the complete path name of the new
help file, and it will be read into memory and
initialized to the help index of the new file
(Page 100). If the new file does not exist, or is
in an invalid format, THELP will beep twice, and
return you to the original file.
J key: Jump to specified help page number. 'J' or 'j'
brings up a window that allows you to jump to any
particular page (9999 max) in the help file. The
only editing key permitted in this window is
BackSpace. ESC aborts, CR (or four digits)
completes.
K key: Search help file for specified keyword. 'K' or 'k'
brings up a window in which you can enter a
keyword (40 characters max), and have THELP search
the help file for a match. If there is no matching
keyword in the current help file, THELP will beep
twice and return you to the original help screen.
I key: Paste highlighted keyword into application. 'I' or
'i' inserts the current highlighted keyword into
the keyboard buffer, and immediately pops down.
P key: Paste entire help screen into application. 'P' or
'p' inserts the entire current help page (as it
appears in the help window) into the current
application, and then immediately pops down.
Pasting can be interrupted with ^C or ^Break.
S Key: Save help screen to disk file (THELP.SAV). 'S' or
's' from any help screen saves the current help
page to the disk file THELP.SAV, in the current
directory. If the file already exists, the new
help information is appended to the end.
<Hotkey Combo>
Pressing the hotkey combination when using THELP
on a second monitor ends this session of the
resident help, but leaves the current help screen
on the monochrome monitor.
4. Detailed Explanation of Command-line Options
------------------------------------------------
/B -- Use BIOS for video
This option forces THELP to use Interrupt 10h BIOS video calls
for all writing to/reading from the video display. Normally, THELP
will write directly to video RAM. Note that the use of this
option negates the effect of the /M switch described below; the
alternate monitor may not be used if /B is in effect. This option
is enabled with '/B+', and disabled with '/B-' (enable is the
default).
/C#xx Select color: #=color number, xx=hex color value
There are eight possible colors, described as follows:
1 = Color Normal Text
2 = Monochrome Normal Text
3 = Color Possible reference pages; top/bottom description line
4 = Monochrome Possible reference pages; top/bottom description line
5 = Color Border Color
6 = Monochrome Border Color
7 = Color Current Reference Selection
8 = Monochrome Current Reference Selection
Any or all of these eight colors may be specified on the command
line.
The color numbers for a standard IBM-compatible Color Display are
as follows:
First Digit (Background) Second Digit (Foreground)
0 -- Black 0 -- Black
1 -- Blue 1 -- Blue
2 -- Green 2 -- Green
3 -- Cyan 3 -- Cyan
4 -- Red 4 -- Red
5 -- Magenta 5 -- Magenta
6 -- Brown 6 -- Brown
7 -- Grey 7 -- Grey
8 -- Intense Black
ORing the color value with 9 -- Intense Blue
Hex 80 produces a blinking A -- Intense Green
color unless blinking has been B -- Intense Cyan
disabled. C -- Intense Red
D -- Intense Magenta
E -- Intense Brown (Yellow)
F -- Intense Grey (White)
On Monochrome monitors, the attribute values can differ widely,
so some experimentation would be needed. Note that the monochrome
attributes are used in only two cases; when the current video
mode is 7, or when force mono is used (see the /M option)
/Dname -- Full path for disk swapping (implies /S1)
This option is used to override where THELP will place its swap
files when swapping to disk. A full path should be specified,
but a trailing '\' is not necessary. If no /D option is
specified, under DOS 3.x swap files are placed in the directory
where THELP.COM resides. Under DOS 2.x, swap files are placed by
default in C:\.
Using this option also sets the flag that forces disk swapping
instead of checking first for EMS.
/Fname -- Full path and filename of help file
The name that follows the /F option should be the full
drive/directory pathname of the help file to use; e.g.,
THELP /FC:\TP\TURBO.HLP
THELP /FC:\TURBOC\TCHELP.TCH
By default, THELP looks for the help file on the logged drive and
directory.
/H,/?,? -- Display help screen
This option displays a summary of THELP's command-line options
/Kxxyy -- Change hotkey: xx=shift state, yy=scan code
Virtually any shift state/scan code combination may be selected.
A quick summary of some common shift-states and scan codes
follows:
Shift States (may be OR'ed together)
right shift 01h
left shift 02h
control 04h
alt 08h
Scan Codes
A --- 1eh N --- 31h 0 --- 0bh F1 --- 3bh
B --- 30h O --- 18h 1 --- 02h F2 --- 3ch
C --- 2eh P --- 19h 2 --- 03h F3 --- 3dh
D --- 20h Q --- 10h 3 --- 04h F4 --- 3eh
E --- 12h R --- 13h 4 --- 05h F5 --- 3fh
F --- 21h S --- 1fh 5 --- 06h F6 --- 40h
G --- 22h T --- 14h 6 --- 07h F7 --- 41h
H --- 23h U --- 16h 7 --- 08h F8 --- 42h
I --- 17h V --- 2fh 8 --- 09h F9 --- 43h
J --- 24h W --- 11h 9 --- 0ah F10 --- 44h
K --- 25h X --- 2dh
L --- 26h Y --- 15h
M --- 32h Z --- 2ch
Enhanced Keyboards only (may not work with all computers,
keyboards)
F11 --- 57h
F12 --- 58h
/Lxx -- Force number of rows on screen: xx=25,43,50
Some video adapters do not correctly store the number of video
rows on the screen in the BIOS data location specified for the
IBM-PC. This option forces THELP to use the given value, rather
than the number the BIOS reports.
/M+,/M- -- Display help text: on monochrome screen(+),
on default screen(-)
For users with dual-monitor systems, this option may be used to
instruct THELP to bring up its display on the monochrome monitor,
rather than on the color monitor. This option is enabled with
'/M+', and disabled with '/M-' (enable is the default). Note that
/M is incompatible with /B (see above).
/Px -- Pasting speed: 0=slow, 1=medium, 2=fast
Some editors do not accept characters pasted into the keyboard
buffer as fast as THELP can put them there. By setting an
appropriate paste speed, virtually all possible configurations of
editors may be used. FAST speed pastes as many characters as will
fit on every timer tick; MEDIUM pastes up to four characters per
tick; and SLOW pastes a single character into the buffer ONLY
when the buffer is empty.
/R -- Send options to resident THELP
The /R option is used to pass parameters (like new colors, or new
hotkeys) to the resident portion of THELP. All THELP command-line
options may be sent to the resident portion except for the
swapping mode, which cannot be modified once THELP has been
initialized.
In combination with these options, you can create a batch file
that changes THELP's configuration as you change editors; i.e.:
THELP /M /P0 /FC:\TP\TURBO.HLP /R
Use mono monitor, slow pasting, and the Turbo Pascal help
file. Options are not saved to disk.
THELP /P2 /FC:\TC\TCHELP.TCH /R
Use default monitor, fast pasting, and the Turbo C help file.
Options are not saved to disk.
/Sx -- Default Swapping Mode: 1=Use Disk, 2=Use EMS,
3=No Swapping
If no '/S' parameter is used, THELP first tests to see if
Expanded Memory is available in the system. If so, and if enough
memory can be allocated, swapping is done to EMS. If EMS is not
available, disk swapping is used. See the /D parameter for
information on where the swap file will be written if disk
swapping is used.
/U -- Remove THELP from memory
This option is used to remove THELP from memory. If other TSRs
have been loaded after THELP, make sure to remove them before
removing THELP.
/W -- Write Options to THELP.COM and exit
The /W parameter is used to create a new version of THELP that
uses the options you desire as a default. All options, including
/S (but not /R) may be specified and made 'permanent'.


33
Borland Turbo Pascal v55/DOC/TURBO3.DOC Normal file
View File

@ -0,0 +1,33 @@
{*******************************************************}
{ }
{ Turbo Pascal Version 5.5 }
{ 3.0 Compatibility Unit }
{ }
{ Copyright (C) 1987, 1989 Borland International }
{ }
{*******************************************************}
unit Turbo3;
{$D-,I-,S-}
interface
uses Crt;
var
Kbd: Text;
CBreak: Boolean absolute CheckBreak;
procedure AssignKbd(var F: Text);
function MemAvail: Integer;
function MaxAvail: Integer;
function LongFileSize(var F): Real;
function LongFilePos(var F): Real;
procedure LongSeek(var F; Pos: Real);
procedure NormVideo;
procedure HighVideo;
procedure LowVideo;
function IOresult: Integer;


221
Borland Turbo Pascal v55/DOSSTM.ASM Normal file
View File

@ -0,0 +1,221 @@
; Turbo Pascal 5.5 object-oriented example
; Assembler code for OBJECTS.PAS unit
; Copyright (c) 1989 by Borland International, Inc.
TITLE DOSSTM
INCLUDE OBJECTS.INC
CODE SEGMENT BYTE PUBLIC
EXTRN StreamError:NEAR
ASSUME CS:CODE
PUBLIC DosStream@GetPos
DosStream@GetPos PROC FAR
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CMP ES:[DI].Stream@Status,0
JNE @@1
XOR CX,CX
MOV DX,CX
MOV BX,ES:[DI].DosStream@Handle
MOV AX,4201H
INT 21H
JNC @@2
CALL StreamError
@@1: MOV AX,-1
MOV DX,AX
@@2: POP BP
RET 4
DosStream@GetPos ENDP
PUBLIC DosStream@Read
DosStream@Read PROC FAR
@Buf EQU (DWORD PTR [BP+12])
@Count EQU (WORD PTR [BP+10])
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CMP ES:[DI].Stream@Status,0
JNE @@2
PUSH DS
LDS DX,@Buf
MOV CX,@Count
MOV BX,ES:[DI].DosStream@Handle
MOV AH,3FH
INT 21H
POP DS
JC @@1
CMP AX,CX
JE @@3
MOV AX,100
@@1: CALL StreamError
@@2: LES DI,@Buf
MOV CX,@Count
XOR AL,AL
CLD
REP STOSB
@@3: POP BP
RET 10
DosStream@Read ENDP
PUBLIC DosStream@SetPos
DosStream@SetPos PROC FAR
@Pos EQU (DWORD PTR [BP+12])
@Mode EQU (BYTE PTR [BP+10])
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CALL StreamFlush
JNE @@1
MOV DX,@Pos.w0
MOV CX,@Pos.w2
MOV BX,ES:[DI].DosStream@Handle
MOV AL,@Mode
MOV AH,42H
INT 21H
JNC @@1
CALL StreamError
@@1: POP BP
RET 10
DosStream@SetPos ENDP
PUBLIC DosStream@Truncate
DosStream@Truncate PROC FAR
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CALL StreamFlush
JNE @@1
XOR CX,CX
MOV BX,ES:[DI].DosStream@Handle
MOV AH,40H
INT 21H
JNC @@1
CALL StreamError
@@1: POP BP
RET 4
DosStream@Truncate ENDP
PUBLIC DosStream@Write
DosStream@Write PROC FAR
@Buf EQU (DWORD PTR [BP+12])
@Count EQU (WORD PTR [BP+10])
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CMP ES:[DI].Stream@Status,0
JNE @@2
PUSH DS
LDS DX,@Buf
MOV CX,@Count
MOV BX,ES:[DI].DosStream@Handle
MOV AH,40H
INT 21H
POP DS
JC @@1
CMP AX,CX
JE @@2
MOV AX,101
@@1: CALL StreamError
@@2: POP BP
RET 10
DosStream@Write ENDP
PUBLIC DosStream@Close
DosStream@Close PROC FAR
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
CALL StreamFlush
JNE @@1
MOV BX,ES:[DI].DosStream@Handle
MOV AH,3EH
INT 21H
@@1: POP BP
RET 4
DosStream@Close ENDP
PUBLIC DosStream@Open
DosStream@Open PROC FAR
@Name EQU (DWORD PTR [BP+12])
@Mode EQU (WORD PTR [BP+10])
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@Self
PUSH DS
LDS DX,@Name
XOR CX,CX
MOV AX,@Mode
INT 21H
POP DS
JNC @@1
CALL StreamError
MOV AX,0FFFFH
@@1: MOV ES:[DI].DosStream@Handle,AX
POP BP
RET 10
DosStream@Open ENDP
; Call stream flush procedure
; In ES:DI = Stream object pointer
; Out ZF = Status test
; Uses AX,BX,CX,DX,SI
StreamFlush PROC NEAR
PUSH ES
PUSH DI
PUSH ES
PUSH DI
MOV DI,ES:[DI]
CALL [DI].Stream$Flush
POP DI
POP ES
CMP ES:[DI].Stream@Status,0
RET
StreamFlush ENDP
CODE ENDS
END


BIN
Borland Turbo Pascal v55/DOSSTM.OBJ Normal file
View File

Binary file not shown.

28
Borland Turbo Pascal v55/DOS_GT.BAK Normal file
View File

@ -0,0 +1,28 @@
type
regpack = record
ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
end;
procedure get_time( var tt : timetype );
var
recpack: regpack;
ah,al,ch,cl,dh: byte;
begin
ah := $2c;
with recpack do
begin
ax := ah shl 8 + al;
end;
intr( $21, recpack );
with recpack do
begin
tt.h := cx shr 8;
tt.m := cx mod 256;
tt.s := dx shr 8;
tt.l := dx mod 256;
end;
end;


27
Borland Turbo Pascal v55/DOS_GT.PAS Normal file
View File

@ -0,0 +1,27 @@
type
regpack = record
ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
end;
procedure get_time( var tt : timetype );
var
recpack: registers;
ahigh: byte;
begin
ahigh := $2c;
with recpack do
begin
ax := ahigh shl 8;
end;
intr( $21, recpack );
with recpack do
begin
tt.h := cx shr 8;
tt.m := cx mod 256;
tt.s := dx shr 8;
tt.l := dx mod 256;
end;
end;

35
Borland Turbo Pascal v55/DRIVERS.PAS Normal file
View File

@ -0,0 +1,35 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
unit Drivers;
{ Sample unit to accompany BGILINK.PAS. This unit links the BGI graphics
driver into a single TPU file. This makes it easy to link the driver files
directly into an .EXE file. See BGILINK.PAS for more information.
}
interface
procedure ATTDriverProc;
procedure CgaDriverProc;
procedure EgaVgaDriverProc;
procedure HercDriverProc;
procedure PC3270DriverProc;
implementation
procedure ATTDriverProc; external;
{$L ATT.OBJ }
procedure CgaDriverProc; external;
{$L CGA.OBJ }
procedure EgaVgaDriverProc; external;
{$L EGAVGA.OBJ }
procedure HercDriverProc; external;
{$L HERC.OBJ }
procedure PC3270DriverProc; external;
{$L PC3270.OBJ }
end.


42
Borland Turbo Pascal v55/E.PAS Normal file
View File

@ -0,0 +1,42 @@
program e;
const
DIGITS = 200;
type
arrayType = array[ 0..DIGITS ] of integer;
var
high, n, x : integer;
a : arrayType;
begin
high := DIGITS;
x := 0;
n := high - 1;
while n > 0 do begin
a[ n ] := 1;
n := n - 1;
end;
a[ 1 ] := 2;
a[ 0 ] := 0;
while high > 9 do begin
high := high - 1;
n := high;
while 0 <> n do begin
a[ n ] := x MOD n;
x := 10 * a[ n - 1 ] + x DIV n;
n := n - 1;
end;
Write( x );
end;
writeln;
writeln( 'done' );
end.


BIN
Borland Turbo Pascal v55/EGAVGA.BGI Normal file
View File

Binary file not shown.

439
Borland Turbo Pascal v55/EMS.PAS Normal file
View File

@ -0,0 +1,439 @@
program Ems_Test;
{ *************************************************************
* This program shows you how to use the basic functions of *
* the LIM Expanded Memory Specification. Since it does not *
* use any of the LIM EMS 4.0 function calls, you can also *
* use it on systems with EMS versions less than 4.0 *
************************************************************* }
{ Written by:
Peter Immarco.
Thought Dynamics
Manhattan Beach, CA
Compuserve ID# 73770,123
*** Public Domain ***
Used by permission of the author.
}
{ This program does the following:
+------------------------------------------------------------+
| * Makes sure the LIM Expanded Memory Manager (EMM) has |
| been installed in memory |
| * Displays the version number of the EMM present in memory |
| * Determines if there are enough pages (16k blocks) of |
| memory for our test program's usage. It then displays |
| the total number of EMS pages present in the system, |
| and how many are available for our usage |
| * Requests the desired number of pages from the EMM |
| * Maps a logical page onto one of the physical pages given |
| to us |
| * Displays the base address of our EMS memory page frame |
| * Performs a simple read/write test on the EMS memory given|
| to us |
| * Returns the EMS memory given to us back to the EMM, and |
| exits |
+------------------------------------------------------------|}
{ All the calls are structured to return the result or error
code of the Expanded Memory function performed as an integer.
If the error code is not zero, which means the call failed,
a simple error procedure is called and the program terminates.}
uses Crt, Dos;
Type
ST3 = string[3];
ST80 = string[80];
ST5 = string[5];
Const
EMM_INT = $67;
DOS_Int = $21;
GET_PAGE_FRAME = $41;
GET_UNALLOCATED_PAGE_COUNT= $42;
ALLOCATE_PAGES = $43;
MAP_PAGES = $44;
DEALLOCATE_PAGES = $45;
GET_VERSION = $46;
STATUS_OK = 0;
{ We'll say we need 1 EMS page for our application }
APPLICATION_PAGE_COUNT = 1;
Var
Regs: Registers;
Emm_Handle,
Page_Frame_Base_Address,
Pages_Needed,
Physical_Page,
Logical_Page,
Offset,
Error_Code,
Pages_EMS_Available,
Total_EMS_Pages,
Available_EMS_Pages: Word;
Version_Number,
Pages_Number_String: ST3;
Verify: Boolean;
{ * --------------------------------------------------------- * }
{ The function Hex_String converts an Word into a four
character hexadecimal number(string) with leading zeroes. }
Function Hex_String(Number: Word): ST5;
Function Hex_Char(Number: Word): Char;
Begin
If Number<10 then
Hex_Char:=Char(Number+48)
else
Hex_Char:=Char(Number+55);
end; { Function Hex_Char }
Var
S: ST5;
Begin
S:='';
S:=Hex_Char( (Number shr 1) div 2048);
Number:=( ((Number shr 1) mod 2048) shl 1)+
(Number and 1) ;
S:=S+Hex_Char(Number div 256);
Number:=Number mod 256;
S:=S+Hex_Char(Number div 16);
Number:=Number mod 16;
S:=S+Hex_Char(Number);
Hex_String:=S+'h';
end; { Function Hex_String }
{ * --------------------------------------------------------- * }
{ The function Emm_Installed checks to see if the Expanded
Memory Manager (EMM) is loaded in memory. It does this by
looking for the string 'EMMXXXX0', which should be located
at 10 bytes from the beginning of the code segment pointed
to by the EMM interrupt, 67h }
Function Emm_Installed: Boolean;
Var
Emm_Device_Name : string[8];
Int_67_Device_Name : string[8];
Position : Word;
Regs : registers;
Begin
Int_67_Device_Name:='';
Emm_Device_Name :='EMMXXXX0';
with Regs do
Begin
{ Get the code segment pointed to by Interrupt 67h, the EMM
interrupt by using DOS call $35, 'get interrupt vector' }
AH:=$35;
AL:=EMM_INT;
Intr(DOS_int,Regs);
{ The ES pseudo-register contains the segment address pointed
to by Interrupt 67h }
{ Create an 8 character string from the 8 successive bytes
pointed to by ES:$0A (10 bytes from ES) }
For Position:=0 to 7 do
Int_67_Device_Name:=
Int_67_Device_Name+Chr(mem[ES:Position+$0A]);
Emm_Installed:=True;
{ Is it the EMM manager signature, 'EMMXXXX0'? then EMM is
installed and ready for use, if not, then the EMM manager
is not present }
If Int_67_Device_Name<>Emm_Device_Name
then Emm_Installed:=False;
end; { with Regs do }
end; { Function Emm_Installed }
{ * --------------------------------------------------------- * }
{ This function returns the total number of EMS pages present
in the system, and the number of EMS pages that are
available for our use }
Function EMS_Pages_Available
(Var Total_EMS_Pages,Pages_Available: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:=Get_Unallocated_Page_Count;
intr(EMM_INT,Regs);
{ The number of EMS pages available is returned in BX }
Pages_Available:=BX;
{ The total number of pages present in the system is
returned in DX }
Total_EMS_Pages:=DX;
{ Return the error code }
EMS_Pages_Available:=AH
end;
end; { EMS_Pages_Available }
{ * --------------------------------------------------------- * }
{ This function requests the desired number of pages from the
EMM }
Function Allocate_Expanded_Memory_Pages
(Pages_Needed: Word; Var Handle: Word ): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:= Allocate_Pages;
{ Put the desired number of pages in BX }
BX:=Pages_Needed;
intr(EMM_INT,Regs);
{ Our EMS handle is returned in DX }
Handle:=DX;
{ Return the error code }
Allocate_Expanded_Memory_Pages:=AH;
end;
end; { Function Allocate_Expanded_Memory_Pages }
{ * --------------------------------------------------------- * }
{ This function maps a logical page onto one of the physical
pages made available to us by the
Allocate_Expanded_Memory_Pages function }
Function Map_Expanded_Memory_Pages
(Handle,Logical_Page,Physical_Page: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:=Map_Pages;
{ Put the physical page number to be mapped into AL }
AL:=Physical_Page;
{ Put the logical page number to be mapped in BX }
BX:=Logical_Page;
{ Put the EMS handle assigned to us earlier in DX }
DX:=Handle;
Intr(EMM_INT,Regs);
{ Return the error code }
Map_Expanded_Memory_Pages:=AH;
end; { with Regs do }
end; { Function Map_Expanded_Memory_Pages }
{ * --------------------------------------------------------- * }
{ This function gets the physical address of the EMS page
frame we are using. The address returned is the segment
of the page frame. }
Function Get_Page_Frame_Base_Address
(Var Page_Frame_Address: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-
register }
AH:=Get_Page_Frame;
intr(EMM_INT,Regs);
{ The page frame base address is returned in BX }
Page_Frame_Address:=BX;
{ Return the error code }
Get_Page_Frame_Base_Address:=AH;
end; { Regs }
end; { Function Get_Page_Frame_Base_Address }
{ * --------------------------------------------------------- * }
{ This function releases the EMS memory pages allocated to
us, back to the EMS memory pool. }
Function Deallocate_Expanded_Memory_Pages
(Handle: Word): Word;
Var
Regs: Registers;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-register }
AH:=DEALLOCATE_PAGES;
{ Put the EMS handle assigned to our EMS memory pages in DX }
DX:=Emm_Handle;
Intr(EMM_INT,Regs);
{ Return the error code }
Deallocate_Expanded_Memory_Pages:=AH;
end; { with Regs do }
end; { Function Deallocate_Expanded_Memory_Pages }
{ * --------------------------------------------------------- * }
{ This function returns the version number of the EMM as
a 3 character string. }
Function Get_Version_Number(Var Version_String: ST3): Word;
Var
Regs: Registers;
Word_Part,Fractional_Part: Char;
Begin
with Regs do
Begin
{ Put the desired EMS function number in the AH pseudo-register }
AH:=GET_VERSION;
Intr(EMM_INT,Regs);
{ See if call was successful }
If AH=STATUS_OK then
Begin
{ The upper four bits of AH are the Word portion of the
version number, the lower four bits are the fractional
portion. Convert the Word value to ASCII by adding 48. }
Word_Part := Char( AL shr 4 + 48);
Fractional_Part:= Char( AL and $F +48);
Version_String:= Word_Part+'.'+Fractional_Part;
end; { If AH=STATUS_OK }
{ Return the function calls error code }
Get_Version_Number:=AH;
end; { with Regs do }
end; { Function Get_Version_Number }
{ * --------------------------------------------------------- * }
{ This procedure prints an error message passed by the caller,
prints the error code passed by the caller in hex, and then
terminates the program with the an error level of 1 }
Procedure Error(Error_Message: ST80; Error_Number: Word);
Begin
Writeln(Error_Message);
Writeln(' Error_Number = ',Hex_String(Error_Number) );
Writeln('EMS test program aborting.');
Halt(1);
end; { Procedure Error_Message }
{ * --------------------------------------------------------- * }
{ EMS_TEST }
{ This program is an example of the basic EMS functions that you
need to execute in order to use EMS memory with Turbo Pascal }
Begin
ClrScr;
Window(5,2,77,22);
{ Determine if the Expanded Memory Manager is installed, If
not, then terminate 'main' with an ErrorLevel code of 1. }
If not (Emm_Installed) then
Begin
Writeln('The LIM Expanded Memory Manager is not installed.');
Halt(1);
end;
{ Get the version number and display it }
Error_Code:= Get_Version_Number(Version_Number);
If Error_Code<>STATUS_OK then
Error('Error trying to get the EMS version number ',
Error_code)
else
Writeln('LIM Expanded Memory Manager, version ',
Version_Number,' is ready for use.');
Writeln;
{ Determine if there are enough expanded memory pages for this
application. }
Pages_Needed:=APPLICATION_PAGE_COUNT;
Error_Code:=
EMS_Pages_Available(Total_EMS_Pages,Available_EMS_Pages);
If Error_Code<>STATUS_OK then
Error('Error trying to determine the number of EMS pages available.',
Error_code);
Writeln('There are a total of ',Total_EMS_Pages,
' expanded memory pages present in this system.');
Writeln(' ',Available_EMS_Pages,
' of those pages are available for your usage.');
Writeln;
{ If there is an insufficient number of pages for our application,
then report the error and terminate the EMS test program }
If Pages_Needed>Available_EMS_Pages then
Begin
Str(Pages_Needed,Pages_Number_String);
Error('We need '+Pages_Number_String+
' EMS pages. There are not that many available.',
Error_Code);
end; { Pages_Needed>Available_EMS_Pages }
{ Allocate expanded memory pages for our usage }
Error_Code:= Allocate_Expanded_Memory_Pages(Pages_Needed,Emm_Handle);
Str(Pages_Needed,Pages_Number_String);
If Error_Code<>STATUS_OK then
Error('EMS test program failed trying to allocate '+Pages_Number_String+
' pages for usage.',Error_Code);
Writeln(APPLICATION_PAGE_COUNT,
' EMS page(s) allocated for the EMS test program.');
Writeln;
{ Map in the required logical pages to the physical pages
given to us, in this case just one page }
Logical_Page :=0;
Physical_Page:=0;
Error_Code:=
Map_Expanded_Memory_Pages(
Emm_Handle,Logical_Page,Physical_Page);
If Error_Code<>STATUS_OK then
Error('EMS test program failed trying to map '+
'logical pages onto physical pages.',Error_Code);
Writeln('Logical Page ',Logical_Page,
' successfully mapped onto Physical Page ',
Physical_Page);
Writeln;
{ Get the expanded memory page frame address }
Error_Code:= Get_Page_Frame_Base_Address(Page_Frame_Base_Address);
If Error_Code<>STATUS_OK then
Error('EMS test program unable to get the base Page'+
' Frame Address.',Error_Code);
Writeln('The base address of the EMS page frame is - '+
Hex_String(Page_Frame_Base_Address) );
Writeln;
{ Write a test pattern to expanded memory }
For Offset:=0 to 16382 do
Mem[Page_Frame_Base_Address:Offset]:=Offset mod 256;
{ Make sure that what is in EMS memory is what we just wrote }
Writeln('Testing EMS memory.');
Offset:=1;
Verify:=True;
while (Offset<=16382) and (Verify=True) do
Begin
If Mem[Page_Frame_Base_Address:Offset]<>Offset mod 256 then
Verify:=False;
Offset:=Succ(Offset);
end; { while (Offset<=16382) and (Verify=True) }
{ If it isn't report the error }
If not Verify then
Error('What was written to EMS memory was not found during '+
'memory verification test.',0);
Writeln('EMS memory test successful.');
Writeln;
{ Return the expanded memory pages given to us back to the
EMS memory pool before terminating our test program }
Error_Code:=Deallocate_Expanded_Memory_Pages(Emm_Handle);
If Error_Code<>STATUS_OK then
Error('EMS test program was unable to deallocate '+
'the EMS pages in use.',Error_Code);
Writeln(APPLICATION_PAGE_COUNT,
' page(s) deallocated.');
Writeln;
Writeln('EMS test program completed.');
end.


22
Borland Turbo Pascal v55/ERROR.PAS Normal file
View File

@ -0,0 +1,22 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
unit Error;
{ Sample unit for CIRCULAR.PAS }
interface
procedure ShowError(Msg : string);
implementation
uses
Crt, Display;
procedure ShowError(Msg : string);
begin
WriteXY(1, 25, 'Error: ' + Msg);
end;
end.


BIN
Borland Turbo Pascal v55/EXECDEMO.EXE Normal file
View File

Binary file not shown.

71
Borland Turbo Pascal v55/EXECDEMO.MAP Normal file
View File

@ -0,0 +1,71 @@
Start Stop Length Name Class
00000H 00151H 00152H EXECDEMO CODE
00160H 0029EH 0013FH DOS CODE
002A0H 00B0AH 0086BH SYSTEM CODE
00B10H 00E1BH 0030CH DATA DATA
00E20H 02E1FH 02000H STACK STACK
02E20H 02E20H 00000H HEAP HEAP
Address Publics by Value
0000:0048 @
0016:0000 SWAPVECTORS
0016:0038 EXEC
0016:00CC DOSEXITCODE
0016:00D1 GETENV
00B1:0002 OVRCODELIST
00B1:0004 OVRHEAPSIZE
00B1:0006 OVRDEBUGPTR
00B1:000A OVRHEAPORG
00B1:000C OVRHEAPPTR
00B1:000E OVRHEAPEND
00B1:0010 OVRLOADLIST
00B1:0012 OVRDOSHANDLE
00B1:0014 OVREMSHANDLE
00B1:0016 HEAPORG
00B1:001A HEAPPTR
00B1:001E FREEPTR
00B1:0022 FREEMIN
00B1:0024 HEAPERROR
00B1:0028 EXITPROC
00B1:002C EXITCODE
00B1:002E ERRORADDR
00B1:0032 PREFIXSEG
00B1:0034 STACKLIMIT
00B1:0036 INOUTRES
00B1:0038 RANDSEED
00B1:003C FILEMODE
00B1:003D TEST8087
00B1:003E COMMAND
00B1:00BE DOSERROR
00B1:00C4 INPUT
00B1:01C4 OUTPUT
00B1:02C4 SAVEINT00
00B1:02C8 SAVEINT02
00B1:02CC SAVEINT1B
00B1:02D0 SAVEINT23
00B1:02D4 SAVEINT24
00B1:02D8 SAVEINT34
00B1:02DC SAVEINT35
00B1:02E0 SAVEINT36
00B1:02E4 SAVEINT37
00B1:02E8 SAVEINT38
00B1:02EC SAVEINT39
00B1:02F0 SAVEINT3A
00B1:02F4 SAVEINT3B
00B1:02F8 SAVEINT3C
00B1:02FC SAVEINT3D
00B1:0300 SAVEINT3E
00B1:0304 SAVEINT3F
00B1:0308 SAVEINT75
Line numbers for EXECDEMO(EXECDEMO.PAS) segment EXECDEMO
26 0000:0048 28 0000:0054 29 0000:0070 30 0000:008D
32 0000:0097 33 0000:009C 34 0000:00D8 35 0000:0107
36 0000:010C 37 0000:0113 38 0000:012F 40 0000:013E
41 0000:0148
Program entry point at 0000:0048

41
Borland Turbo Pascal v55/EXECDEMO.PAS Normal file
View File

@ -0,0 +1,41 @@
{ Turbo Exec }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program ExecDemo;
(*
Demonstration program that shows how to use the Dos
unit's Exec procedure to execute DOS commands (including
running other programs or batch files).
This program keeps prompting you for a DOS command until
you enter a blank line.
When using Exec, make sure you specify a {$M} directive
so the heap leaves some memory available for the child
process.
*)
{$M 8192,0,0} { Leave memory for child process }
uses Dos;
var
Command: string[127];
begin
repeat
Write('Enter DOS command: ');
ReadLn(Command);
if Command <> '' then
begin
SwapVectors;
WriteLn( 'comspec: ' + GetEnv('COMSPEC') );
Exec(GetEnv('COMSPEC'), '/C ' + Command);
SwapVectors;
if DosError <> 0 then
WriteLn('Could not execute COMMAND.COM');
WriteLn;
end;
until Command = '';
end.

83
Borland Turbo Pascal v55/FDEMO.PAS Normal file
View File

@ -0,0 +1,83 @@
{ Turbo Form }
{ Copyright (c) 1989 by Borland International, Inc. }
program FDemo;
{ Turbo Pascal 5.5 object-oriented example.
Demonstrates use of the FORMS and SLIDERS units.
Refer to OOPDEMOS.DOC for an overview of this program.
}
uses Crt, Forms, Sliders;
type
Person = record
Firstname: string[30];
Lastname: string[30];
Address: string[32];
City: string[16];
State: string[2];
Zipcode: Longint;
Counter: array[1..3] of Longint;
Slider: array[1..2] of Integer;
end;
const
Frank: Person = (
Firstname: 'Frank';
Lastname: 'Borland';
Address: '1800 Green Hills Road';
City: 'Scotts Valley';
State: 'CA';
Zipcode: 95066;
Counter: (10, 1000, 65536);
Slider: (85, 25));
var
F: Form;
P: Person;
begin
Color(BackColor);
ClrScr;
Color(ForeColor);
GotoXY(1, 1); ClrEol;
Write(' Turbo Pascal 5.5 Object Oriented Forms Editor');
GotoXY(1, 25); ClrEol;
Write(' F2-Save Esc-Quit');
F.Init(10, 5, 54, 16);
F.Add(New(FStrPtr, Init(3, 2, ' Firstname ', 30)));
F.Add(New(FStrPtr, Init(3, 3, ' Lastname ', 30)));
F.Add(New(FStrPtr, Init(3, 5, ' Address ', 32)));
F.Add(New(FStrPtr, Init(3, 6, ' City ', 16)));
F.Add(New(FStrPtr, Init(25, 6, ' State ', 2)));
F.Add(New(FZipPtr, Init(34, 6, ' Zip ')));
F.Add(New(FIntPtr, Init(3, 8, ' Counter 1 ', 0, 99999999)));
F.Add(New(FIntPtr, Init(22, 8, ' 2 ', 0, 99999999)));
F.Add(New(FIntPtr, Init(33, 8, ' 3 ', 0, 99999999)));
F.Add(New(FSliderPtr, Init(3, 10, ' Slider One ', 0, 100, 5)));
F.Add(New(FSliderPtr, Init(3, 11, ' Slider Two ', 0, 100, 5)));
P := Frank;
F.Put(P);
F.Show(True);
if F.Edit = CSave then F.Get(P);
F.Done;
NormVideo;
ClrScr;
WriteLn('Resulting Person record:');
WriteLn;
with P do
begin
WriteLn('Firstname: ', Firstname);
WriteLn(' Lastname: ', Lastname);
WriteLn(' Address: ', Address);
WriteLn(' City: ', City);
WriteLn(' State: ', State);
WriteLn(' Zipcode: ', Zipcode);
WriteLn(' Counters: ', Counter[1], ' ', Counter[2], ' ', Counter[3]);
WriteLn(' Sliders: ', Slider[1], ' ', Slider[2]);
end;
end.


45
Borland Turbo Pascal v55/FIB8087.PAS Normal file
View File

@ -0,0 +1,45 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
{$N+,E+}
program Fib8087;
{
Sample program from P-335 in the Owner's Handbook that
demonstrates how to avoid 8087 stack overflow in recursive
functions that use the 8087 math co-processor. Local variables
are used to store temporary results on the 8086 stack.
}
var
i : integer;
function Fib(N : integer) : extended;
{ calculate the fibonacci sequence for N }
var
F1, F2 : extended;
begin
if N = 0 then
Fib := 0.0
else
if N = 1 then
Fib := 1.0
else
begin
(* Use this line instead of the 3 lines that follow this
comment to cause an 8087 stack overflow for values of
N >= 8:
Fib := Fib(N - 1) + Fib(N - 2); { will cause overflow for N > 8 }
*)
F1 := Fib(N - 1); { store results in temporaries on 8086 }
F2 := Fib(N - 2); { stack to avoid 8087 stack overflow }
Fib := F1 + F2;
end;
end; { Fib }
begin
for i := 0 to 15 do
Writeln(i, '. ', Fib(i));
end.


94
Borland Turbo Pascal v55/FIGDEMO.PAS Normal file
View File

@ -0,0 +1,94 @@
{ Copyright (c) 1989 by Borland Interational, Inc. }
program FigureDemo;
{ From P-47 of the Object-Oriented Programming Guide.
Extending FIGURES.PAS with type Arc.
}
uses Crt, DOS, Graph, Figures;
type
Arc = object (Circle)
StartAngle, EndAngle : Integer;
constructor Init(InitX, InitY : Integer;
InitRadius : Integer;
InitStartAngle, InitEndAngle : Integer);
procedure Show; virtual;
procedure Hide; virtual;
end;
var
GraphDriver : Integer;
GraphMode : Integer;
ErrorCode : Integer;
AnArc : Arc;
ACircle : Circle;
{--------------------------------------------------------}
{ Arc's method declarations: }
{--------------------------------------------------------}
constructor Arc.Init(InitX,InitY : Integer;
InitRadius : Integer;
InitStartAngle, InitEndAngle : Integer);
begin
Circle.Init(InitX, InitY, InitRadius);
StartAngle := InitStartAngle;
EndAngle := InitEndAngle;
end;
procedure Arc.Show;
begin
Visible := True;
Graph.Arc(X, Y, StartAngle, EndAngle, Radius);
end;
procedure Arc.Hide;
var
TempColor : Word;
begin
TempColor := Graph.GetColor;
Graph.SetColor(GetBkColor);
Visible := False;
{ Draw the arc in the background color to hide it }
Graph.Arc(X, Y, StartAngle, EndAngle, Radius);
SetColor(TempColor);
end;
{--------------------------------------------------------}
{ Main program: }
{--------------------------------------------------------}
begin
GraphDriver := Detect; { Let the BGI determine what board
you're using }
DetectGraph(GraphDriver, GraphMode);
InitGraph(GraphDriver, GraphMode,'');
if GraphResult <> GrOK then
begin
WriteLn('>>Halted on graphics error:',
GraphErrorMsg(GraphDriver));
Halt(1)
end;
{ All descendents of type Point contain virtual methods and }
{ *must* be initialized before use through a constructor call. }
ACircle.Init(151, 82, { Initial X,Y at 151,82 }
50); { Initial radius of 50 pixels }
AnArc.Init(151, 82, { Initial X,Y at 151,82 }
25, 0, 90); { Initial radius of 50 pixels }
{ Start angle: 0; End angle: 90 }
{ Replace AnArc with ACircle to drag a circle instead of an }
{ arc. Press Enter to stop dragging and end the program. }
ACircle.Drag(5); { Parameter is # of pixels to drag by }
CloseGraph;
RestoreCRTMode;
end.


201
Borland Turbo Pascal v55/FIGURES.PAS Normal file
View File

@ -0,0 +1,201 @@
{ Turbo Figures }
{ Copyright (c) 1989 by Borland Interational, Inc. }
unit Figures;
{ From P-42 of the Object-Oriented Programming Guide.
Virtual methods & polymorphic objects.
}
interface
uses Graph, Crt;
type
Location = object
X,Y : Integer;
procedure Init(InitX, InitY : Integer);
function GetX : Integer;
function GetY : Integer;
end;
PointPtr = ^Point;
Point = object (Location)
Visible : Boolean;
constructor Init(InitX, InitY : Integer);
destructor Done; virtual;
procedure Show; virtual;
procedure Hide; virtual;
function IsVisible : Boolean;
procedure MoveTo(NewX, NewY : Integer);
procedure Drag(DragBy : Integer); virtual;
end;
CirclePtr = ^Circle;
Circle = object (Point)
Radius : Integer;
constructor Init(InitX, InitY : Integer;
InitRadius : Integer);
procedure Show; virtual;
procedure Hide; virtual;
procedure Expand(ExpandBy : Integer); virtual;
procedure Contract(ContractBy : Integer); virtual;
end;
implementation
{--------------------------------------------------------}
{ Location's method implementations: }
{--------------------------------------------------------}
procedure Location.Init(InitX, InitY : Integer);
begin
X := InitX;
Y := InitY;
end;
function Location.GetX : Integer;
begin
GetX := X;
end;
function Location.GetY : Integer;
begin
GetY := Y;
end;
{--------------------------------------------------------}
{ Points's method implementations: }
{--------------------------------------------------------}
constructor Point.Init(InitX, InitY : Integer);
begin
Location.Init(InitX, InitY);
Visible := False;
end;
destructor Point.Done;
begin
Hide;
end;
procedure Point.Show;
begin
Visible := True;
PutPixel(X, Y, GetColor);
end;
procedure Point.Hide;
begin
Visible := False;
PutPixel(X, Y, GetBkColor);
end;
function Point.IsVisible : Boolean;
begin
IsVisible := Visible;
end;
procedure Point.MoveTo(NewX, NewY : Integer);
begin
Hide;
X := NewX;
Y := NewY;
Show;
end;
function GetDelta(var DeltaX : Integer;
var DeltaY : Integer) : Boolean;
var
KeyChar : Char;
Quit : Boolean;
begin
DeltaX := 0; DeltaY := 0; { 0 means no change in position; }
GetDelta := True; { True means we return a delta }
repeat
KeyChar := ReadKey; { First, read the keystroke }
Quit := True; { Assume it's a useable key }
case Ord(KeyChar) of
0: begin { 0 means an extended, 2-byte code }
KeyChar := ReadKey; { Read second byte of code }
case Ord(KeyChar) of
72: DeltaY := -1; { Up arrow; decrement Y }
80: DeltaY := 1; { Down arrow; increment Y }
75: DeltaX := -1; { Left arrow; decrement X }
77: DeltaX := 1; { Right arrow; increment X }
else Quit := False; { Ignore any other code }
end; { case }
end;
13: GetDelta := False; { CR pressed means no delta }
else Quit := False; { Ignore any other keystroke }
end; { case }
until Quit;
end;
procedure Point.Drag(DragBy : Integer);
var
DeltaX, DeltaY : Integer;
FigureX, FigureY : Integer;
begin
Show; { Display figure to be dragged }
FigureX := GetX; { Get the initial position of figure }
FigureY := GetY;
{ This is the drag loop : }
while GetDelta(DeltaX, DeltaY) do
begin { Apply delta to figure X,Y: }
FigureX := FigureX + (DeltaX * DragBy);
FigureY := FigureY + (DeltaY * DragBy);
MoveTo(FigureX, FigureY); { And tell the figure to move }
end;
end;
{--------------------------------------------------------}
{ Circle's method implementations: }
{--------------------------------------------------------}
constructor Circle.Init(InitX, InitY : Integer;
InitRadius : Integer);
begin
Point.Init(InitX, InitY);
Radius := InitRadius;
end;
procedure Circle.Show;
begin
Visible := True;
Graph.Circle(X, Y, Radius);
end;
procedure Circle.Hide;
var
TempColor : Word;
begin
TempColor := Graph.GetColor;
Graph.SetColor(GetBkColor);
Visible := False;
Graph.Circle(X, Y, Radius);
Graph.SetColor(TempColor);
end;
procedure Circle.Expand(ExpandBy : Integer);
begin
Hide;
Radius := Radius + ExpandBy;
if Radius <0 then Radius := 0;
Show;
end;
procedure Circle.Contract(ContractBy : Integer);
begin
Expand(-ContractBy);
end;
{ No initialization section }
end.


31
Borland Turbo Pascal v55/FONTS.PAS Normal file
View File

@ -0,0 +1,31 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
unit Fonts;
{ Sample unit to accompany BGILINK.PAS. This unit links all the BGI graphics
fonts into a single TPU file. This makes it easy to incorporate the font
files directly into an .EXE file. See BGILINK.PAS for more information.
}
interface
procedure GothicFontProc;
procedure SansSerifFontProc;
procedure SmallFontProc;
procedure TriplexFontProc;
implementation
procedure GothicFontProc; external;
{$L GOTH.OBJ }
procedure SansSerifFontProc; external;
{$L SANS.OBJ }
procedure SmallFontProc; external;
{$L LITT.OBJ }
procedure TriplexFontProc; external;
{$L TRIP.OBJ }
end.


571
Borland Turbo Pascal v55/FORMS.PAS Normal file
View File

@ -0,0 +1,571 @@
{ Turbo Forms }
{ Copyright (c) 1989 by Borland International, Inc. }
unit Forms;
{ Turbo Pascal 5.5 object-oriented example.
This unit defines field- and form-editing object types.
Refer to OOPDEMOS.DOC for an overview of this unit.
}
{$S-}
interface
uses Objects;
const
CSkip = ^@;
CHome = ^A;
CRight = ^D;
CPrev = ^E;
CEnd = ^F;
CDel = ^G;
CBack = ^H;
CSave = ^J;
CEnter = ^M;
CUndo = ^R;
CLeft = ^S;
CIns = ^V;
CNext = ^X;
CClear = ^Y;
CEsc = ^[;
type
FStringPtr = ^FString;
FString = string[79];
FieldPtr = ^Field;
Field = object(Node)
X, Y, Size: Integer;
Title: FStringPtr;
Value: Pointer;
Extra: record end;
constructor Init(PX, PY, PSize: Integer; PTitle: FString);
constructor Load(var S: Stream);
destructor Done; virtual;
procedure Clear; virtual;
function Edit: Char; virtual;
procedure Show; virtual;
procedure Store(var S: Stream);
end;
FTextPtr = ^FText;
FText = object(Field)
Len: Integer;
constructor Init(PX, PY, PSize: Integer; PTitle: FString;
PLen: Integer);
function Edit: Char; virtual;
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
procedure Show; virtual;
end;
FStrPtr = ^FStr;
FStr = object(FText)
constructor Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
end;
FNumPtr = ^FNum;
FNum = object(FText)
procedure Show; virtual;
end;
FIntPtr = ^FInt;
FInt = object(FNum)
Min, Max: Longint;
constructor Init(PX, PY: Integer; PTitle: FString;
PMin, PMax: Longint);
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
end;
FZipPtr = ^FZip;
FZip = object(FInt)
constructor Init(PX, PY: Integer; PTitle: FString);
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
end;
FRealPtr = ^FReal;
FReal = object(FNum)
Decimals: Integer;
constructor Init(PX, PY: Integer; PTitle: FString;
PLen, PDecimals: Integer);
procedure GetStr(var S: FString); virtual;
function PutStr(var S: FString): Boolean; virtual;
end;
FormPtr = ^Form;
Form = object(Base)
X1, Y1, X2, Y2, Size: Integer;
Fields: List;
constructor Init(PX1, PY1, PX2, PY2: Integer);
constructor Load(var S: Stream);
destructor Done; virtual;
function Edit: Char;
procedure Show(Erase: Boolean);
procedure Add(P: FieldPtr);
procedure Clear;
procedure Get(var FormBuf);
procedure Put(var FormBuf);
procedure Store(var S: Stream);
end;
FStream = object(BufStream)
procedure RegisterTypes; virtual;
end;
ColorIndex = (BackColor, ForeColor, TitleColor, ValueColor);
procedure Beep;
procedure Color(C: ColorIndex);
function ReadChar: Char;
implementation
uses Crt;
type
Bytes = array[0..32767] of Byte;
{ Field }
constructor Field.Init(PX, PY, PSize: Integer; PTitle: FString);
begin
X := PX;
Y := PY;
Size := PSize;
GetMem(Title, Length(PTitle) + 1);
Title^ := PTitle;
GetMem(Value, Size);
end;
constructor Field.Load(var S: Stream);
var
L: Byte;
begin
S.Read(X, SizeOf(Integer) * 3);
S.Read(L, SizeOf(Byte));
GetMem(Title, L + 1);
Title^[0] := Chr(L);
S.Read(Title^[1], L);
GetMem(Value, Size);
S.Read(Extra, SizeOf(Self) - SizeOf(Field));
end;
destructor Field.Done;
begin
FreeMem(Value, Size);
FreeMem(Title, Length(Title^) + 1);
end;
procedure Field.Clear;
begin
FillChar(Value^, Size, 0);
end;
function Field.Edit: Char;
begin
Abstract;
end;
procedure Field.Show;
begin
Abstract;
end;
procedure Field.Store(var S: Stream);
begin
S.Write(X, SizeOf(Integer) * 3);
S.Write(Title^, Length(Title^) + 1);
S.Write(Extra, SizeOf(Self) - SizeOf(Field));
end;
{ FText }
constructor FText.Init(PX, PY, PSize: Integer; PTitle: FString;
PLen: Integer);
begin
Field.Init(PX, PY, PSize, PTitle);
Len := PLen;
end;
function FText.Edit: Char;
var
P: Integer;
Ch: Char;
Start, Stop: Boolean;
S: FString;
begin
P := 0;
Start := True;
Stop := False;
GetStr(S);
repeat
GotoXY(X, Y);
Color(TitleColor);
Write(Title^);
Color(ValueColor);
Write(S, '': Len - Length(S));
GotoXY(X + Length(Title^) + P, Y);
Ch := ReadChar;
case Ch of
#32..#255:
begin
if Start then S := '';
if Length(S) < Len then
begin
Inc(P);
Insert(Ch, S, P);
end;
end;
CLeft: if P > 0 then Dec(P);
CRight: if P < Length(S) then Inc(P) else;
CHome: P := 0;
CEnd: P := Length(S);
CDel: Delete(S, P + 1, 1);
CBack:
if P > 0 then
begin
Delete(S, P, 1);
Dec(P);
end;
CClear:
begin
S := '';
P := 0;
end;
CUndo:
begin
GetStr(S);
P := 0;
end;
CEnter, CNext, CPrev, CSave:
if PutStr(S) then
begin
Show;
Stop := True;
end else
begin
Beep;
P := 0;
end;
CEsc: Stop := True;
else
Beep;
end;
Start := False;
until Stop;
Edit := Ch;
end;
procedure FText.GetStr(var S: FString);
begin
Abstract;
end;
function FText.PutStr(var S: FString): Boolean;
begin
Abstract;
end;
procedure FText.Show;
var
S: FString;
begin
GetStr(S);
GotoXY(X, Y);
Color(TitleColor);
Write(Title^);
Color(ValueColor);
Write(S, '': Len - Length(S));
end;
{ FStr }
constructor FStr.Init(PX, PY: Integer; PTitle: FString; PLen: Integer);
begin
FText.Init(PX, PY, PLen + 1, PTitle, PLen);
end;
procedure FStr.GetStr(var S: FString);
begin
S := FString(Value^);
end;
function FStr.PutStr(var S: FString): Boolean;
begin
FString(Value^) := S;
PutStr := True;
end;
{ FNum }
procedure FNum.Show;
var
S: FString;
begin
GetStr(S);
GotoXY(X, Y);
Color(TitleColor);
Write(Title^);
Color(ValueColor);
Write(S: Len);
end;
{ FInt }
constructor FInt.Init(PX, PY: Integer; PTitle: FString;
PMin, PMax: Longint);
var
L: Integer;
S: string[15];
begin
Str(PMin, S); L := Length(S);
Str(PMax, S); if L < Length(S) then L := Length(S);
FNum.Init(PX, PY, SizeOf(Longint), PTitle, L);
Min := PMin;
Max := PMax;
end;
procedure FInt.GetStr(var S: FString);
begin
Str(Longint(Value^), S);
end;
function FInt.PutStr(var S: FString): Boolean;
var
N: Longint;
E: Integer;
begin
Val(S, N, E);
if (E = 0) and (N >= Min) and (N <= Max) then
begin
Longint(Value^) := N;
PutStr := True;
end else PutStr := False;
end;
{ FZip }
constructor FZip.Init(PX, PY: Integer; PTitle: FString);
begin
FInt.Init(PX, PY, PTitle, 0, 99999);
end;
procedure FZip.GetStr(var S: FString);
begin
FInt.GetStr(S);
Insert(Copy('0000', 1, 5 - Length(S)), S, 1);
end;
function FZip.PutStr(var S: FString): Boolean;
begin
PutStr := (Length(S) = 5) and FInt.PutStr(S);
end;
{ FReal }
constructor FReal.Init(PX, PY: Integer; PTitle: FString;
PLen, PDecimals: Integer);
begin
FNum.Init(PX, PY, SizeOf(Real), PTitle, PLen);
Decimals := PDecimals;
end;
procedure FReal.GetStr(var S: FString);
begin
Str(Real(Value^): 0: Decimals, S);
end;
function FReal.PutStr(var S: FString): Boolean;
var
R: Real;
E: Integer;
T: FString;
begin
Val(S, R, E);
PutStr := False;
if E = 0 then
begin
Str(R: 0: Decimals, T);
if Length(T) <= Len then
begin
Real(Value^) := R;
PutStr := True;
end;
end;
end;
{ Form }
constructor Form.Init(PX1, PY1, PX2, PY2: Integer);
begin
X1 := PX1;
Y1 := PY1;
X2 := PX2;
Y2 := PY2;
Size := 0;
Fields.Clear;
end;
constructor Form.Load(var S: Stream);
begin
S.Read(X1, SizeOf(Integer) * 5);
Fields.Load(S);
end;
destructor Form.Done;
begin
Fields.Delete;
end;
function Form.Edit: Char;
var
P: FieldPtr;
Ch: Char;
begin
Window(X1, Y1, X2, Y2);
P := FieldPtr(Fields.First);
repeat
Ch := P^.Edit;
case Ch of
CEnter, CNext: P := FieldPtr(P^.Next);
CPrev: P := FieldPtr(P^.Prev);
end;
until (Ch = CSave) or (Ch = CEsc);
Edit := Ch;
Window(1, 1, 80, 25);
end;
procedure Form.Show(Erase: Boolean);
var
P: FieldPtr;
begin
Window(X1, Y1, X2, Y2);
if Erase then
begin
Color(ForeColor);
ClrScr;
end;
P := FieldPtr(Fields.First);
while P <> nil do
begin
P^.Show;
P := FieldPtr(Fields.Next(P));
end;
Window(1, 1, 80, 25);
end;
procedure Form.Add(P: FieldPtr);
begin
Inc(Size, P^.Size);
Fields.Append(P);
end;
procedure Form.Clear;
var
P: FieldPtr;
begin
P := FieldPtr(Fields.First);
while P <> nil do
begin
P^.Clear;
P := FieldPtr(Fields.Next(P));
end;
end;
procedure Form.Get(var FormBuf);
var
I: Integer;
P: FieldPtr;
begin
I := 0;
P := FieldPtr(Fields.First);
while P <> nil do
begin
Move(P^.Value^, Bytes(FormBuf)[I], P^.Size);
Inc(I, P^.Size);
P := FieldPtr(Fields.Next(P));
end;
end;
procedure Form.Put(var FormBuf);
var
I: Integer;
P: FieldPtr;
begin
I := 0;
P := FieldPtr(Fields.First);
while P <> nil do
begin
Move(Bytes(FormBuf)[I], P^.Value^, P^.Size);
Inc(I, P^.Size);
P := FieldPtr(Fields.Next(P));
end;
end;
procedure Form.Store(var S: Stream);
begin
S.Write(X1, SizeOf(Integer) * 5);
Fields.Store(S);
end;
{ FStream }
procedure FStream.RegisterTypes;
begin
BufStream.RegisterTypes;
Register(TypeOf(FStr), @FStr.Store, @FStr.Load);
Register(TypeOf(FInt), @FInt.Store, @FInt.Load);
Register(TypeOf(FZip), @FZip.Store, @FZip.Load);
Register(TypeOf(FReal), @FReal.Store, @FReal.Load);
end;
{ Global routines }
procedure Beep;
begin
Sound(500); Delay(25); NoSound;
end;
procedure Color(C: ColorIndex);
type
Palette = array[ColorIndex] of Byte;
const
CP: Palette = ($17, $70, $30, $5E);
MP: Palette = ($07, $70, $70, $07);
begin
if LastMode = CO80 then TextAttr := CP[C] else TextAttr := MP[C];
end;
function ReadChar: Char;
var
Ch: Char;
begin
Ch := ReadKey;
case Ch of
#0:
case ReadKey of
#15, #72: Ch := CPrev; { Shift-Tab, Up }
#60: Ch := CSave; { F2 }
#71: Ch := CHome; { Home }
#75: Ch := CLeft; { Left }
#77: Ch := CRight; { Right }
#79: Ch := CEnd; { End }
#80: Ch := CNext; { Down }
#82: Ch := CIns; { Ins }
#83: Ch := CDel; { Del }
end;
#9: Ch := CNext; { Tab }
end;
ReadChar := Ch;
end;
end.


BIN
Borland Turbo Pascal v55/GOTH.CHR Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v55/GRAPH.TPU Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v55/GREP.COM Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v55/HERC.BGI Normal file
View File

Binary file not shown.

246
Borland Turbo Pascal v55/HILB.PAS Normal file
View File

@ -0,0 +1,246 @@
{$N-}
program Hilb;
{
The program performs simultaneous solution by Gauss-Jordan
elimination.
--------------------------------------------------
From: Pascal Programs for Scientists and Engineers
Alan R. Miller, Sybex
n x n inverse hilbert matrix
solution is 1 1 1 1 1
double precision version
--------------------------------------------------
INSTRUCTIONS
1. Compile and run the program using the $N- (Numeric Processing :
Software) compiler directive.
2. if you have a math coprocessor in your computer, compile and run the
program using the $N+ (Numeric Processing : Hardware) compiler
directive. Compare the speed and precision of the results to those
of example 1.
}
const
maxr = 10;
maxc = 10;
type
{$IFOPT N+} { use extended type if using 80x87 }
real = extended;
{$ENDIF}
ary = array[1..maxr] of real;
arys = array[1..maxc] of real;
ary2s = array[1..maxr, 1..maxc] of real;
var
y : arys;
coef : arys;
a, b : ary2s;
n, m, i, j : integer;
error : boolean;
procedure gaussj
(var b : ary2s; (* square matrix of coefficients *)
y : arys; (* constant vector *)
var coef : arys; (* solution vector *)
ncol : integer; (* order of matrix *)
var error: boolean); (* true if matrix singular *)
(* Gauss Jordan matrix inversion and solution *)
(* Adapted from McCormick *)
(* Feb 8, 81 *)
(* B(N,N) coefficient matrix, becomes inverse *)
(* Y(N) original constant vector *)
(* W(N,M) constant vector(s) become solution vector *)
(* DETERM is the determinant *)
(* ERROR = 1 if singular *)
(* INDEX(N,3) *)
(* NV is number of constant vectors *)
var
w : array[1..maxc, 1..maxc] of real;
index: array[1..maxc, 1..3] of integer;
i, j, k, l, nv, irow, icol, n, l1 : integer;
determ, pivot, hold, sum, t, ab, big: real;
procedure swap(var a, b: real);
var
hold: real;
begin (* swap *)
hold := a;
a := b;
b := hold
end (* procedure swap *);
begin (* Gauss-Jordan main program *)
error := false;
nv := 1 (* single constant vector *);
n := ncol;
for i := 1 to n do
begin
w[i, 1] := y[i] (* copy constant vector *);
index[i, 3] := 0
end;
determ := 1.0;
for i := 1 to n do
begin
(* search for largest element *)
big := 0.0;
for j := 1 to n do
begin
if index[j, 3] <> 1 then
begin
for k := 1 to n do
begin
if index[k, 3] > 1 then
begin
writeln(' ERROR: matrix singular');
error := true;
exit; (* abort *)
end;
if index[k, 3] < 1 then
if abs(b[j, k]) > big then
begin
irow := j;
icol := k;
big := abs(b[j, k])
end
end (* k loop *)
end
end (* j loop *);
index[icol, 3] := index[icol, 3] + 1;
index[i, 1] := irow;
index[i, 2] := icol;
(* interchange rows to put pivot on diagonal *)
if irow <> icol then
begin
determ := - determ;
for l := 1 to n do
swap(b[irow, l], b[icol, l]);
if nv > 0 then
for l := 1 to nv do
swap(w[irow, l], w[icol, l])
end; (* if irow <> icol *)
(* divide pivot row by pivot column *)
pivot := b[icol, icol];
determ := determ * pivot;
b[icol, icol] := 1.0;
for l := 1 to n do
b[icol, l] := b[icol, l] / pivot;
if nv > 0 then
for l := 1 to nv do
w[icol, l] := w[icol, l] / pivot;
(* reduce nonpivot rows *)
for l1 := 1 to n do
begin
if l1 <> icol then
begin
t := b[l1, icol];
b[l1, icol] := 0.0;
for l := 1 to n do
b[l1, l] := b[l1, l] - b[icol, l] * t;
if nv > 0 then
for l := 1 to nv do
w[l1, l] := w[l1, l] - w[icol, l] * t;
end (* if l1 <> icol *)
end
end (* i loop *);
if error then exit;
(* interchange columns *)
for i := 1 to n do
begin
l := n - i + 1;
if index[l, 1] <> index[l, 2] then
begin
irow := index[l, 1];
icol := index[l, 2];
for k := 1 to n do
swap(b[k, irow], b[k, icol])
end (* if index *)
end (* i loop *);
for k := 1 to n do
if index[k, 3] <> 1 then
begin
writeln(' ERROR: matrix singular');
error := true;
exit; (* abort *)
end;
for i := 1 to n do
coef[i] := w[i, 1];
end (* procedure gaussj *);
procedure get_data(var a : ary2s;
var y : arys;
var n, m : integer);
(* setup n-by-n hilbert matrix *)
var
i, j : integer;
begin
for i := 1 to n do
begin
a[n,i] := 1.0/(n + i - 1);
a[i,n] := a[n,i]
end;
a[n,n] := 1.0/(2*n -1);
for i := 1 to n do
begin
y[i] := 0.0;
for j := 1 to n do
y[i] := y[i] + a[i,j]
end;
writeln;
if n < 7 then
begin
for i:= 1 to n do
begin
for j:= 1 to m do
write( a[i,j] :7:5, ' ');
writeln( ' : ', y[i] :7:5)
end;
writeln
end (* if n<7 *)
end (* procedure get_data *);
procedure write_data;
(* print out the answers *)
var
i : integer;
begin
for i := 1 to m do
write( coef[i] :13:9);
writeln;
end (* write_data *);
begin (* main program *)
a[1,1] := 1.0;
n := 2;
m := n;
repeat
get_data (a, y, n, m);
for i := 1 to n do
for j := 1 to n do
b[i,j] := a[i,j] (* setup work array *);
gaussj (b, y, coef, n, error);
if not error then write_data;
n := n+1;
m := n
until n > maxr;
end.


BIN
Borland Turbo Pascal v55/IBM8514.BGI Normal file
View File

Binary file not shown.

187
Borland Turbo Pascal v55/LISTDEMO.PAS Normal file
View File

@ -0,0 +1,187 @@
{ Turbo List }
{ Copyright (c) 1989 by Borland Interational, Inc. }
program ListDemo;
{ From P-57 of the Object-Oriented Programming Guide.
Dynamic objects & destructors.
}
uses Graph, Figures;
type
ArcPtr = ^Arc;
Arc = object(Circle)
StartAngle, EndAngle : Integer;
constructor Init(InitX, InitY : Integer;
InitRadius : Integer;
InitStartAngle, InitEndAngle : Integer);
procedure Show; virtual;
procedure Hide; virtual;
end;
NodePtr = ^Node;
Node = record
Item : PointPtr;
Next : NodePtr;
end;
ListPtr = ^List;
List = object
Nodes: NodePtr;
constructor Init;
destructor Done; virtual;
procedure Add(Item : PointPtr);
procedure Report;
end;
var
GraphDriver : Integer;
GraphMode : Integer;
Temp : String;
AList : List;
PArc : ArcPtr;
PCircle : CirclePtr;
RootNode : NodePtr;
{--------------------------------------------------------}
{ Procedures that are not methods: }
{--------------------------------------------------------}
procedure OutTextLn(TheText : String);
begin
OutText(TheText);
MoveTo(0, GetY+12);
end;
procedure HeapStatus(StatusMessage : String);
begin
Str(MemAvail : 6, Temp);
OutTextLn(StatusMessage+Temp);
end;
{--------------------------------------------------------}
{ Arc's method implementations: }
{--------------------------------------------------------}
constructor Arc.Init(InitX, InitY : Integer;
InitRadius : Integer;
InitStartAngle, InitEndAngle : Integer);
begin
Circle.Init(InitX, InitY, InitRadius);
StartAngle := InitStartAngle;
EndAngle := InitEndAngle;
end;
procedure Arc.Show;
begin
Visible := True;
Graph.Arc(X, Y, StartAngle, EndAngle, Radius);
end;
procedure Arc.Hide;
var
TempColor : Word;
begin
TempColor := Graph.GetColor;
Graph.SetColor(GetBkColor);
Visible := False;
Graph.Arc(X, Y, StartAngle, EndAngle, Radius);
SetColor(TempColor);
end;
{--------------------------------------------------------}
{ List's method implementations: }
{--------------------------------------------------------}
constructor List.Init;
begin
Nodes := nil;
end;
destructor List.Done;
var
N : NodePtr;
begin
while Nodes <> nil do
begin
N := Nodes;
Nodes := N^.Next;
Dispose(N^.Item, Done);
Dispose(N);
end;
end;
procedure List.Add(Item : PointPtr);
var
N : NodePtr;
begin
New(N);
N^.Item := Item;
N^.Next := Nodes;
Nodes := N;
end;
procedure List.Report;
var
Current : NodePtr;
begin
Current := Nodes;
while Current <> nil do
begin
Str(Current^.Item^.GetX : 3, Temp);
OutTextLn('X = '+Temp);
Str(Current^.Item^.GetY : 3, Temp);
OutTextLn('Y = '+Temp);
Current := Current^.Next;
end;
end;
{--------------------------------------------------------}
{ Main program: }
{--------------------------------------------------------}
begin
{ Let the BGI determine what board you're using: }
DetectGraph(GraphDriver, GraphMode);
InitGraph(GraphDriver, GraphMode,'');
if GraphResult <> GrOK then
begin
WriteLn('>>Halted on graphics error: ',
GraphErrorMsg(GraphDriver));
Halt(1);
end;
HeapStatus('Heap space before list is allocated: ');
{ Create a list }
AList.Init;
{ Now create and add several figures to it in one operation }
AList.Add(New(ArcPtr, Init(151, 82, 25, 200, 330)));
AList.Add(New(CirclePtr, Init(400, 100, 40)));
AList.Add(New(CirclePtr, Init(305, 136, 5)));
{ Traverse the list and display X,Y of the list's figures }
AList.Report;
HeapStatus('Heap space after list is allocated ');
{ Deallocate the whole list with one destructor call }
AList.Done;
HeapStatus('Heap space after list is cleaned up: ');
OutText('Press Enter to end program: ');
Readln;
CloseGraph;
end.


212
Borland Turbo Pascal v55/LISTER.PAS Normal file
View File

@ -0,0 +1,212 @@
{ Turbo List }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program SourceLister;
{
SOURCE LISTER DEMONSTRATION PROGRAM
This is a simple program to list your TURBO PASCAL source programs.
PSEUDO CODE
1. Find Pascal source file to be listed
2. Initialize program variables
3. Open main source file
4. Process the file
a. Read a character into line buffer until linebuffer full or eoln;
b. Search line buffer for include file.
c. If line contains include file command:
Then process include file and extract command from line buffer
Else print out the line buffer.
d. Repeat step 4.a thru 4.c until eof(main file);
INSTRUCTIONS
1. Compile and run the program:
a. In the Development Environment load LISTER.PAS and
press ALT-R.
b. From the command line type TPC LISTER.PAS /R
2. Specify the file to print.
}
uses
Printer;
const
PageWidth = 80;
PrintLength = 55;
PathLength = 65;
FormFeed = #12;
VerticalTabLength = 3;
type
WorkString = string[126];
FileName = string[PathLength];
var
CurRow : integer;
MainFileName: FileName;
MainFile: text;
search1,
search2,
search3,
search4: string[5];
procedure Initialize;
begin
CurRow := 0;
search1 := '{$'+'I'; { different forms that the include compiler }
search2 := '{$'+'i'; { directive can take. }
search3 := '(*$'+'I';
search4 := '(*$'+'i';
end {initialize};
function Open(var fp:text; name: Filename): boolean;
begin
Assign(fp,Name);
{$I-}
Reset(fp);
{$I+}
Open := IOResult = 0;
end { Open };
procedure OpenMain;
begin
if ParamCount = 0 then
begin
Write('Enter filename: ');
Readln(MainFileName);
end
else
MainFileName := ParamStr(1);
if (MainFileName = '') or not Open(MainFile,MainFileName) then
begin
Writeln('ERROR: file not found (', MainFileName, ')');
Halt(1);
end;
end {Open Main};
procedure VerticalTab;
var i: integer;
begin
for i := 1 to VerticalTabLength do Writeln(LST);
end {vertical tab};
procedure ProcessLine(PrintStr: WorkString);
begin
CurRow := Succ(CurRow);
if Length(PrintStr) > PageWidth then Inc(CurRow);
if CurRow > PrintLength then
begin
Write(LST,FormFeed);
VerticalTab;
CurRow := 1;
end;
Writeln(LST,PrintStr);
end {Process line};
procedure ProcessFile;
{ This procedure displays the contents of the Turbo Pascal program on the }
{ printer. It recursively processes include files if they are nested. }
var
LineBuffer: WorkString;
function IncludeIn(var CurStr: WorkString): boolean;
var
ChkChar: char;
column: integer;
begin
ChkChar := '-';
column := Pos(search1,CurStr);
if column <> 0 then
chkchar := CurStr[column+3]
else
begin
column := Pos(search3,CurStr);
if column <> 0 then
chkchar := CurStr[column+4]
else
begin
column := Pos(search2,CurStr);
if column <> 0 then
chkchar := CurStr[column+3]
else
begin
column := Pos(search4,CurStr);
if column <> 0 then
chkchar := CurStr[column+4]
end;
end;
end;
if ChkChar in ['+','-'] then IncludeIn := False
else IncludeIn := True;
end { IncludeIn };
procedure ProcessIncludeFile(var IncStr: WorkString);
var NameStart, NameEnd: integer;
IncludeFile: text;
IncludeFileName: Filename;
Function Parse(IncStr: WorkString): WorkString;
begin
NameStart := Pos('$I',IncStr)+2;
while IncStr[NameStart] = ' ' do
NameStart := Succ(NameStart);
NameEnd := NameStart;
while (not (IncStr[NameEnd] in [' ','}','*']))
and ((NameEnd - NameStart) <= PathLength) do
Inc(NameEnd);
Dec(NameEnd);
Parse := Copy(IncStr,NameStart,(NameEnd-NameStart+1));
end {Parse};
begin {Process include file}
IncludeFileName := Parse(IncStr);
if not Open(IncludeFile,IncludeFileName) then
begin
LineBuffer := 'ERROR: include file not found (' +
IncludeFileName + ')';
ProcessLine(LineBuffer);
end
else
begin
while not EOF(IncludeFile) do
begin
Readln(IncludeFile,LineBuffer);
{ Turbo Pascal 5.5 allows nested include files so we must
check for them and do a recursive call if necessary }
if IncludeIn(LineBuffer) then
ProcessIncludeFile(LineBuffer)
else
ProcessLine(LineBuffer);
end;
Close(IncludeFile);
end;
end {Process include file};
begin {Process File}
VerticalTab;
Writeln('Printing . . . ');
while not EOF(mainfile) do
begin
Readln(MainFile,LineBuffer);
if IncludeIn(LineBuffer) then
ProcessIncludeFile(LineBuffer)
else
ProcessLine(LineBuffer);
end;
Close(MainFile);
Write(LST,FormFeed); { move the printer to the beginning of the next }
{ page }
end {Process File};
begin
Initialize; { initialize some global variables }
OpenMain; { open the file to print }
ProcessFile; { print the program }
end.


BIN
Borland Turbo Pascal v55/LITT.CHR Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v55/MAKE.EXE Normal file
View File

Binary file not shown.

95
Borland Turbo Pascal v55/OBJECTS.INC Normal file
View File

@ -0,0 +1,95 @@
; Turbo Pascal 5.5 object-oriented example
; Assembler include file for OBJECTS.PAS unit
; Copyright (c) 1989 by Borland International, Inc.
; *******************************************************
; * *
; * EQUATES AND MACROS *
; * *
; *******************************************************
LOCALS @@
; Object definition macro
OBJECT MACRO Name,Parent
FIELD MACRO FName,FType,FCount
&Name&@&&FName EQU (FType PTR &Name&@)
&Name&@ = &Name&@ + FType * FCount
ENDM
METHOD MACRO MName
IFE &Name&$
&Name&@VMT EQU (WORD PTR &Name&@)
&Name&@ = &Name&@ + WORD
&Name&$ = 4
ENDIF
&Name&$&&MName EQU (DWORD PTR &Name&$)
&Name&$ = &Name&$ + DWORD
ENDM
IFNB <Parent>
&Name&@ = &Parent&@
&Name&$ = &Parent&$
ELSE
&Name&@ = 0
&Name&$ = 0
ENDIF
ENDM
; 4-Byte record
ByteRec STRUC
b0 DB ?
b1 DB ?
b2 DB ?
b3 DB ?
ByteRec ENDS
; 4-Word record
WordRec STRUC
w0 DW ?
w2 DW ?
w4 DW ?
w6 DW ?
WordRec ENDS
; Base object type
OBJECT Base
METHOD Done
; SProc object type
OBJECT SProc
FIELD StoreProc,DWORD,1
FIELD LoadProc,DWORD,1
; Stream object type
OBJECT Stream,Base
FIELD TypeCount,WORD,1
FIELD TypeList,DWORD,1
FIELD ProcList,DWORD,1
FIELD Status,WORD,1
METHOD Error
METHOD Flush
METHOD GetPos
METHOD Read
METHOD RegisterTypes
METHOD SetPos
METHOD Truncate
METHOD Write
; DosStream object type
OBJECT DosStream,Stream
FIELD Handle,WORD,1
; BufStream object type
OBJECT BufStream,DosStream
FIELD Buffer,DWORD,1
FIELD BufSize,WORD,1
FIELD BufPtr,WORD,1
FIELD BufEnd,WORD,1


459
Borland Turbo Pascal v55/OBJECTS.PAS Normal file
View File

@ -0,0 +1,459 @@
{ Turbo Objects }
{ Copyright (c) 1989 by Borland International, Inc. }
unit Objects;
{ Turbo Pascal 5.5 object-oriented example.
This unit defines some basic object types.
Refer to OOPDEMOS.DOC for an overview of this unit.
}
{$S-}
interface
const
{ Stream access modes }
SCreate = $3C00; { Create new file }
SOpenRead = $3D00; { Read access only }
SOpenWrite = $3D01; { Write access only }
SOpen = $3D02; { Read and write access }
{ SetPos positioning modes }
PosAbs = 0; { Relative to beginning }
PosCur = 1; { Relative to current position }
PosEnd = 2; { Relative to end }
type
{ General conversion types }
WordRec = record
Lo, Hi: Byte;
end;
LongRec = record
Lo, Hi: Word;
end;
PtrRec = record
Ofs, Seg: Word;
end;
{ Abstract base object type }
BasePtr = ^Base;
Base = object
destructor Done; virtual;
end;
{ Stream type list }
STypeListPtr = ^STypeList;
STypeList = array[1..256] of Word;
{ Stream I/O procedure record }
SProc = object
StoreProc: Pointer;
LoadProc: Pointer;
end;
{ Stream I/O procedure list }
SProcListPtr = ^SProcList;
SProcList = array[1..256] of SProc;
{ Abstract stream object type }
StreamPtr = ^Stream;
Stream = object(Base)
TypeCount: Word;
TypeList: STypeListPtr;
ProcList: SProcListPtr;
Status: Integer;
constructor Init;
destructor Done; virtual;
procedure Error(Code: Integer); virtual;
procedure Flush; virtual;
function GetPos: Longint; virtual;
procedure Read(var Buf; Count: Word); virtual;
procedure RegisterTypes; virtual;
procedure SetPos(Pos: Longint; Mode: Byte); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count: Word); virtual;
function Get: BasePtr;
function GetSize: Longint;
procedure Put(B: BasePtr);
procedure Register(TypePtr, StorePtr, LoadPtr: Pointer);
procedure Seek(Pos: Longint);
end;
{ DOS file name string }
FNameStr = string[79];
{ Unbuffered DOS stream }
DosStreamPtr = ^DosStream;
DosStream = object(Stream)
Handle: Word;
constructor Init(FileName: FNameStr; Mode: Word);
destructor Done; virtual;
function GetPos: Longint; virtual;
procedure Read(var Buf; Count: Word); virtual;
procedure SetPos(Pos: Longint; Mode: Byte); virtual;
procedure Truncate; virtual;
procedure Write(var Buf; Count: Word); virtual;
procedure Close;
procedure Open(var Name; Mode: Word);
end;
{ Buffered DOS stream }
BufStreamPtr = ^BufStream;
BufStream = object(DosStream)
Buffer: Pointer;
BufSize: Word;
BufPtr: Word;
BufEnd: Word;
constructor Init(FileName: FNameStr; Mode, Size: Word);
destructor Done; virtual;
procedure Flush; virtual;
function GetPos: Longint; virtual;
procedure Read(var Buf; Count: Word); virtual;
procedure Write(var Buf; Count: Word); virtual;
end;
{ Abstract linked list node type }
NodePtr = ^Node;
Node = object(Base)
Next: NodePtr;
function Prev: NodePtr;
end;
{ Linked list type }
ListPtr = ^List;
List = object
Last: NodePtr;
procedure Append(N: NodePtr);
procedure Clear;
procedure Delete;
function Empty: Boolean;
function First: NodePtr;
procedure Insert(N: NodePtr);
procedure Load(var S: Stream);
function Next(N: NodePtr): NodePtr;
function Prev(N: NodePtr): NodePtr;
procedure Remove(N: NodePtr);
procedure Store(var S: Stream);
end;
{ Abstract notification procedure }
procedure Abstract;
implementation
{$L STREAM} { Stream externals }
{$L DOSSTM} { DosStream externals }
{$L BUFSTM} { BufStream externals }
procedure StreamError; external {STREAM};
{ Base }
destructor Base.Done;
begin
end;
{ Stream }
constructor Stream.Init;
begin
TypeCount := 0;
TypeList := nil;
ProcList := nil;
Status := 0;
RegisterTypes;
GetMem(TypeList, TypeCount * SizeOf(Word));
if TypeList = nil then Fail;
GetMem(ProcList, TypeCount * SizeOf(SProc));
if ProcList = nil then
begin
FreeMem(TypeList, TypeCount * SizeOf(Word));
Fail;
end;
TypeCount := 0;
RegisterTypes;
end;
destructor Stream.Done;
begin
FreeMem(ProcList, TypeCount * SizeOf(SProc));
FreeMem(TypeList, TypeCount * SizeOf(Word));
end;
procedure Stream.Error(Code: Integer);
begin
Status := Code;
end;
procedure Stream.Flush;
begin
end;
function Stream.GetPos: Longint;
begin
Abstract;
end;
procedure Stream.Read(var Buf; Count: Word);
begin
Abstract;
end;
procedure Stream.RegisterTypes;
begin
end;
procedure Stream.SetPos(Pos: Longint; Mode: Byte);
begin
Abstract;
end;
procedure Stream.Truncate;
begin
Abstract;
end;
procedure Stream.Write(var Buf; Count: Word);
begin
Abstract;
end;
function Stream.Get: BasePtr;
external {STREAM};
function Stream.GetSize: Longint;
var
P: Longint;
begin
P := GetPos;
SetPos(0, PosEnd);
GetSize := GetPos;
SetPos(P, PosAbs);
end;
procedure Stream.Put(B: BasePtr);
external {STREAM};
procedure Stream.Register(TypePtr, StorePtr, LoadPtr: Pointer);
begin
Inc(TypeCount);
if TypeList <> nil then
begin
TypeList^[TypeCount] := PtrRec(TypePtr).Ofs;
with ProcList^[TypeCount] do
begin
StoreProc := StorePtr;
LoadProc := LoadPtr;
end;
end;
end;
procedure Stream.Seek(Pos: Longint);
begin
SetPos(Pos, PosAbs);
end;
{ DosStream }
constructor DosStream.Init(FileName: FNameStr; Mode: Word);
var
L: Integer;
begin
if not Stream.Init then Fail;
L := Length(FileName);
Move(FileName[1], FileName[0], L);
FileName[L] := #0;
Open(FileName, Mode);
end;
destructor DosStream.Done;
begin
Close;
Stream.Done;
end;
function DosStream.GetPos: Longint;
external {DOSSTM};
procedure DosStream.Read(var Buf; Count: Word);
external {DOSSTM};
procedure DosStream.SetPos(Pos: Longint; Mode: Byte);
external {DOSSTM};
procedure DosStream.Truncate;
external {DOSSTM};
procedure DosStream.Write(var Buf; Count: Word);
external {DOSSTM};
procedure DosStream.Close;
external {DOSSTM};
procedure DosStream.Open(var Name; Mode: Word);
external {DOSSTM};
{ BufStream }
constructor BufStream.Init(FileName: FNameStr; Mode, Size: Word);
begin
GetMem(Buffer, Size);
if Buffer = nil then Fail;
if not DosStream.Init(FileName, Mode) then
begin
FreeMem(Buffer, Size);
Fail;
end;
BufSize := Size;
BufPtr := 0;
BufEnd := 0;
end;
destructor BufStream.Done;
begin
DosStream.Done;
FreeMem(Buffer, BufSize);
end;
procedure BufStream.Flush;
external {BUFSTM};
function BufStream.GetPos: Longint;
external {BUFSTM};
procedure BufStream.Read(var Buf; Count: Word);
external {BUFSTM};
procedure BufStream.Write(var Buf; Count: Word);
external {BUFSTM};
{ Node }
function Node.Prev: NodePtr;
var
P: NodePtr;
begin
P := @Self;
while P^.Next <> @Self do P := P^.Next;
Prev := P;
end;
{ List }
procedure List.Append(N: NodePtr);
begin
Insert(N);
Last := N;
end;
procedure List.Clear;
begin
Last := nil;
end;
procedure List.Delete;
var
P: NodePtr;
begin
while not Empty do
begin
P := First;
Remove(P);
Dispose(P, Done);
end;
end;
function List.Empty: Boolean;
begin
Empty := Last = nil;
end;
function List.First: NodePtr;
begin
if Last = nil then First := nil else First := Last^.Next;
end;
procedure List.Insert(N: NodePtr);
begin
if Last = nil then Last := N else N^.Next := Last^.Next;
Last^.Next := N;
end;
procedure List.Load(var S: Stream);
var
P: NodePtr;
begin
Clear;
P := NodePtr(S.Get);
while P <> nil do
begin
Append(P);
P := NodePtr(S.Get);
end;
end;
function List.Next(N: NodePtr): NodePtr;
begin
if N = Last then Next := nil else Next := N^.Next;
end;
function List.Prev(N: NodePtr): NodePtr;
begin
if N = First then Prev := nil else Prev := N^.Prev;
end;
procedure List.Remove(N: NodePtr);
var
P: NodePtr;
begin
if Last <> nil then
begin
P := Last;
while (P^.Next <> N) and (P^.Next <> Last) do P := P^.Next;
if P^.Next = N then
begin
P^.Next := N^.Next;
if Last = N then if P = N then Last := nil else Last := P;
end;
end;
end;
procedure List.Store(var S: Stream);
var
P: NodePtr;
begin
P := First;
while P <> nil do
begin
S.Put(P);
P := Next(P);
end;
S.Put(nil);
end;
procedure Abstract;
begin
RunError(211);
end;
end.


BIN
Borland Turbo Pascal v55/OBJECTS.TPU Normal file
View File

Binary file not shown.

161
Borland Turbo Pascal v55/ODEMO.PAS Normal file
View File

@ -0,0 +1,161 @@
{ Turbo Streams }
{ Copyright (c) 1989 by Borland International, Inc. }
program ODemo;
{ Turbo Pascal 5.5 object-oriented example.
Demonstrates use of the OBJECTS unit's Stream, List and Node
object types. See OOPDEMOS.DOC for an overview of this program.
}
uses Objects;
type
TestNodePtr = ^TestNode;
TestNode = object(Node)
procedure Dump; virtual;
end;
IntNodePtr = ^IntNode;
IntNode = object(TestNode)
Value: Longint;
constructor Init(V: Longint);
constructor Load(var S: Stream);
procedure Dump; virtual;
procedure Store(var S: Stream);
end;
StringPtr = ^String;
StrNodePtr = ^StrNode;
StrNode = object(TestNode)
Value: StringPtr;
constructor Init(V: String);
destructor Done; virtual;
constructor Load(var S: Stream);
procedure Dump; virtual;
procedure Store(var S: Stream);
end;
TestList = object(List)
procedure Dump;
end;
TestStream = object(BufStream)
procedure RegisterTypes; virtual;
end;
var
S: TestStream;
L: TestList;
procedure TestNode.Dump;
begin
Abstract;
end;
constructor IntNode.Init(V: Longint);
begin
Value := V;
end;
constructor IntNode.Load(var S: Stream);
begin
S.Read(Value, SizeOf(Longint));
if S.Status <> 0 then Fail;
end;
procedure IntNode.Dump;
begin
WriteLn('Int: ', Value);
end;
procedure IntNode.Store(var S: Stream);
begin
S.Write(Value, SizeOf(Longint));
end;
constructor StrNode.Init(V: String);
begin
GetMem(Value, Length(V) + 1);
Value^ := V;
end;
destructor StrNode.Done;
begin
FreeMem(Value, Length(Value^) + 1);
end;
constructor StrNode.Load(var S: Stream);
var
L: Byte;
begin
S.Read(L, 1);
GetMem(Value, L + 1);
Value^[0] := Chr(L);
S.Read(Value^[1], L);
if S.Status <> 0 then Fail;
end;
procedure StrNode.Dump;
begin
WriteLn('Str: ', Value^);
end;
procedure StrNode.Store(var S: Stream);
begin
S.Write(Value^, Length(Value^) + 1);
end;
procedure TestList.Dump;
var
P: TestNodePtr;
begin
P := TestNodePtr(First);
while P <> nil do
begin
P^.Dump;
P := TestNodePtr(Next(P));
end;
end;
procedure TestStream.RegisterTypes;
begin
DosStream.RegisterTypes;
Register(TypeOf(IntNode), @IntNode.Store, @IntNode.Load);
Register(TypeOf(StrNode), @StrNode.Store, @StrNode.Load);
end;
begin
WriteLn('Creating list.');
L.Clear;
L.Append(New(IntNodePtr, Init(1)));
L.Append(New(IntNodePtr, Init(10)));
L.Append(New(IntNodePtr, Init(100)));
L.Append(New(IntNodePtr, Init(1000)));
L.Append(New(StrNodePtr, Init('Hello world')));
L.Append(New(StrNodePtr, Init('Turbo Pascal version 5.5')));
L.Append(New(IntNodePtr, Init(-1)));
L.Append(New(IntNodePtr, Init(-2)));
WriteLn('List to be saved:');
L.Dump;
WriteLn('Saving list in TEST.DTA.');
S.Init('TEST.DTA', SCreate, 1024);
L.Store(S);
S.Done;
WriteLn('Deleting list.');
L.Delete;
WriteLn('Loading list from TEST.DTA.');
S.Init('TEST.DTA', SOpen, 1024);
L.Load(S);
S.Done;
WriteLn('List that was loaded:');
L.Dump;
end.


678
Borland Turbo Pascal v55/OOPDEMOS.DOC Normal file
View File

@ -0,0 +1,678 @@
Turbo Pascal 5.5 Documentation
Object-Oriented Programming Examples
This file documents the Turbo Pascal 5.5 Object-Oriented
Programming (OOP) examples. There are over 12,000 lines of
examples contained in the OOPDEMOS.ARC file on the disk labeled
OOP/DEMOS/BGI/DOC. (If you have a hard disk and run the INSTALL
program to install Turbo Pascal on your system, it will place the
OOP examples in C:\TP by default.)
TABLE OF CONTENTS
-----------------
1. OBJECTS.PAS - Basic object types unit
2. ODEMO.PAS - An example that uses streams and lists
3. FORMS.PAS - Implements a form entry and edit object
4. SLIDERS.PAS - Implements a slider field
5. FDEMO.PAS - A simple forms editor example
6. CARDS.PAS - Implements a card file object
7. CARDFILE.PAS - A simple card filer applciation
8. CARDGEN.PAS - Card filer forms generator
9. TCALC.PAS - See TCALC.DOC
10. Examples from the Object-Oriented Programming Guide
Four examples are included from the OOP Guide for your
convenience:
POINTS PAS - From P-20 of the OOP Guide
FIGURES PAS - From P-42 of the OOP Guide
FIGDEMO PAS - From P-47 of the OOP Guide
LISTDEMO PAS - From P-57 of the OOP Guide
These examples are fully documented in Chapter 1 of the OOP
Guide.
OBJECTS.PAS - BASIC OBJECT TYPES UNIT
-------------------------------------
The Objects unit implements two basic object types: a Stream and
a List. The Stream type is the object-oriented counterpart of a
Pascal file. Turbo Pascal 5.5 does not allow "file of object"
types, but streams may be used to implement the same
functionality, and much more as the example programs show. The
List type implements a singly-linked list of objects, each of
which must be derived from the Node type.
The Base type
-------------
Base is an abstract object type, and serves only as an ultimate
ancestor for other object types. Objects of type Base are never
instantiated. Object types derived from Base are guaranteed to
have a destructor called Done. In addition, the VMT field of
descendants of Base will always be the first field in the
descendant, which is a prerequisite of types registered with a
stream.
Unless overridden, the Done destructor in Base does nothing
except to dispose the instance when called via the extended
syntax of the Dispose standard procedure.
The Stream type
---------------
Much like an untyped file, a stream implements a number of basic
I/O capabilities, such as opening, closing, reading, writing, and
seeking. What sets a stream apart from an untyped file is its
ability to polymorphically read and write objects. This is best
demonstrated through an example.
Assume that you have three object types, Circle, Rectangle, and
Triangle, each of which are derived from an ancestor type Shape.
In order to read and write such objects to disk you would need a
FILE OF Shape that allows reading and writing of objects of type
Shape as well as descendants of Shape. For a number of reasons,
ordinary Pascal FILE types cannot achieve this. First, objects of
type Circle, Rectangle, and Triangle are most likely not of the
same size, since each will add a varying number of fields to the
basic Shape type. Thus, it would be impossible to determine the
proper record size for a FILE OF Shape. Second, a FILE OF Shape
would need to store additional type information for each object
in the file so that when reading the file, the application can
"know" the types of the objects it is reading.
The Stream type provides the solution to this problem: By
defining a Store and Load method in an object type, and by
registering that type with a stream, the stream can perform
polymorphic I/O through its Put and Get methods. The FORMS.PAS
unit and the CARDFILE.PAS program provide good examples on how to
use streams.
The Stream type is the ancestor of all other streams. It defines
the basic properties of a stream, but most of its methods are
purely abstract and meant to be overridden in descendant types.
FIELDS
TypeCount Number of types registered with the stream.
TypeList Pointer to array of VMT offsets of registered types.
ProcList Pointer to array of Store and Load method pointers.
Status Stream status. When Status is non-zero, an error
has occurred on the stream, and all subsequent
I/O is suspended. The Status field is the
equivalent of the IOResult standard function,
except that you have to manually clear Status to
re-enable I/O operations.
CONSTRUCTORS AND DESTRUCTORS
constructor Init;
Initializes the stream by allocating TypeList and ProcList, and
calling RegisterTypes to register the types known by the
stream.
destructor Done; virtual;
Disposes TypeList and ProcList.
BASIC I/O METHODS
procedure Read(var Buf; Count: Word); virtual;
Reads Count bytes from the stream into Buf. In case of error,
Buf is filled with zeros. This method must be overridden.
procedure Write(var Buf; Count: Word); virtual;
Writes Count bytes from Buf onto the stream. This method must
be overridden.
procedure Flush; virtual;
Flushes the stream's I/O buffer, if any. This method does
nothing unless overridden.
procedure Truncate; virtual;
Truncates the stream at the current position, i.e. makes the
current position the end of the stream. This method must be
overridden.
function GetPos: Longint; virtual;
Returns the current position of the stream, or -1 in case of
error.
procedure SetPos(Pos: Longint; Mode: Byte); virtual;
Sets the current position of the stream to a new position that
is Pos bytes from the stream location given by Mode. Valid Mode
values are given by the constants PosAbs, PosCur, and PosEnd,
which represent the stream's beginning, current position, and
end. This method must be overridden.
function GetSize: Longint;
Returns the current size of a stream. Calls SetPos and GetPos
to find the resulting value. This method should not be
overridden.
procedure Seek(Pos: Longint);
Seeks to the specified position. Corresponds to a call to
SetPos with a Mode value of PosAbs. This method should not be
overridden.
TYPE REGISTRATION METHODS
procedure RegisterTypes; virtual;
Registers all types that should be known to the stream. To
register types with a stream you must override this method and
call the Register method for each type. Within an overridden
RegisterTypes, always first call the inherited RegisterTypes to
register any types required by the ancestor. A type need only
be registered if instances of the type are read and written
using the Get and Put methods. Unless overridden, this method
does nothing.
procedure Register(TypePtr, StorePtr, LoadPtr: Pointer);
Registers a type with the stream. This method must only be used
within a RegisterTypes method. The format of a method call is:
Register(TypeOf(AType), @AType.Store, @AType.Load);
where AType is an object type derived from the Base object type
(i.e. an object type whose ultimate ancestor is Base). AType
must define Store and a methods with the following headers:
procedure Store(var S: Stream);
constructor Load(var S: Stream);
The Store method must write a binary representation of the
object onto the stream S (using S.Write), and the Load
constructor must read such a binary representation back from
the stream S (using S.Read).
POLYMORPHIC I/O METHODS
procedure Put(P: BasePtr);
Writes the specified object to the stream. The type of the
object must have been registered with the stream (using an
overridden RegisterTypes method). Put writes a 16-bit object
type identifier number onto the stream and then calls the
object's Store method, which writes a binary copy of the
object. The 16-bit object type identifier corresponds to the
index of the object type in the TypeList and ProcList arrays.
If the specified object pointer is NIL, a 16-bit zero is
written to the stream. If the object type has not been
registered with the stream, the stream's Error method is called
with an error code of -1.
function Get: BasePtr;
Reads an object from a stream and returns a pointer to it. Get
is the counterpart of Put, and can only read objects that were
written by Put. Get reads the 16-bit object type identifier
from the stream and then calls the object type's Load
constructor, which allocates an object on the heap and reads a
binary copy of it from the stream.
If the 16-bit object type identifier is zero, Get returns a
NIL. If the object type identifier is out of range, the
stream's error method is called with an error code of -2, and
Get returns a NIL.
ERROR HANDLING METHODS
procedure Error(Code: Integer); virtual;
This method is called whenever an error occurs on the stream.
Code contains the 16-bit error code, which for DOS file streams
is a DOS error code (see the Run-time Errors in Appendix D in
the Reference Guide). Unless overridden, the Error method just
stores Code in the stream's Status field.
The DosStream type
------------------
The DosStream type implements a DOS file stream. Data written to
a DosStream is written to a DOS file, and data read from a
DosStream is read from a DOS file.
FIELDS
Handle DOS file handle.
CONSTRUCTORS AND DESTRUCTORS
constructor Init(FileName: FNameStr; Mode: Word);
Calls Stream.Init and then opens the file given by FileName
using the access mode given by Mode. Valid Mode values are
defined by the constants SCreate, SOpenRead, SOpenWrite, and
SOpen. SCreate causes a new file to be created. SOpenRead,
SOpenWrite, and SOpen opens an existing file in read-only mode,
write-only mode, or read/write mode. The DOS file handle is
stored in the Handle field.
destructor Done; virtual;
Closes the file and then calls Stream.Done.
BASIC I/O METHODS
procedure Read(var Buf; Count: Word); virtual;
Implements Read for a DOS file. Count bytes are read from the
file into Buf using DOS function 3FH. In case of error, Buf is
filled with zeros.
procedure Write(var Buf; Count: Word); virtual;
Implements Write for a DOS file. Count bytes are written to the
file from Buf using DOS function 40H.
procedure Truncate; virtual;
Implements Truncate for a DOS file using DOS function 40H with
a count of zero.
function GetPos: Longint; virtual;
Implements GetPos for a DOS file using DOS function 42H.
procedure SetPos(Pos: Longint; Mode: Byte); virtual;
Implements SetPos for a DOS file using DOS function 42H.
procedure Open(var Name; Mode: Word);
Private method which creates or opens the file using DOS
function 3CH or 3DH. Called from DosStream.Init and should
never be called directly.
procedure Close;
Private method which flushes the stream buffer (using the Flush
method) and closes the file. Called from DosStream.Done and
should never be called directly.
The BufStream type
------------------
The BufStream type implements a buffered DOS stream. Input and
output with a BufStream is buffered in blocks of a user specified
size. When an application makes a large number of Read and Write
method calls with a small transfer size, using a BufStream rather
than a DosStream will substantially improve performance. For a
typical stream, a buffer size of 1024 bytes is suggested.
FIELDS
Buffer Pointer to an I/O buffer of BufSize bytes.
BufSize Size of I/O buffer.
BufPtr Index of current buffer position in the buffer.
BufEnd Index of current buffer end in the buffer. BufPtr
is equal to BufEnd, the buffer is empty. When
BufPtr is less than BufEnd, the buffer is in read
mode and the bytes between BufPtr and BufEnd have
been read ahead from the file. When BufPtr is
greater than BufEnd, the file is in write mode
and the bytes between BufEnd and BufPtr have been
written to the file but not yet flushed to disk.
CONSTRUCTORS AND DESTRUCTORS
constructor Init(FileName: FNameStr; Mode, Size: Word);
Allocates a buffer of Size bytes and then calls DosStream.Init.
destructor Done; virtual;
Calls DosStream.Done and then disposes the stream buffer.
BASIC I/O METHODS
procedure Read(var Buf; Count: Word); virtual;
Implements Read for a buffered stream. The stream buffer is
used to buffer disk read operations in blocks of BufSize bytes.
procedure Write(var Buf; Count: Word); virtual;
Implements Write for a buffered stream. The stream buffer is
used to buffer disk write operations in blocks of BufSize
bytes.
procedure Flush; virtual;
Flushes the stream's buffer.
function GetPos: Longint; virtual;
The Node type
-------------
Node is an abstract type that serves as the ultimate ancestor of
all objects that are kept on linked lists using the List type.
The Next field points to the next node on the list. If the node
is the last node on the list, the Next field points to the first
node, thus making the list circular. The Prev method returns a
pointer to the preceding node. If the node is the first node of
the list, the Prev method returns a pointer to the last node.
The List type
-------------
The List type implements the basic algorithms of a circular
linked list. The objects kept on a List must be derived from the
abstract Node type. Other abstract types, such as stacks and
queues, can be built from the List type, since they are simply
restricted versions of the functionality provided by List.
The List type does not inherit and has no virtual methods. For
that reason, no constructors or destructors are needed in the
List object.
FIELDS
Last Pointer to the last node on the list, or NIL if
the list is empty. The Next field of the last
node on a list, i.e. Last^.Next, points to the
first node on the list.
LIST MANAGEMENT METHODS
procedure Clear;
Clears the list by setting the Last field to NIL. Any nodes on
the list are not disposed.
procedure Delete;
Disposes all nodes on the list using their Done destructor.
procedure Append(N: NodePtr);
Appends a node. The new node becomes the first node on the
list.
procedure Insert(N: NodePtr);
Inserts a node. The new node becomes the last node on the list.
procedure Remove(N: NodePtr);
Removes a node. The node itself is not disposed.
function First: NodePtr;
Returns a pointer to the first node on the list, or NIL if the
list is empty. The last node on the list can be directly
accessed through the Last field.
function Next(N: NodePtr): NodePtr;
Returns a pointer to the node after N, or NIL if N is the last
node. This corresponds to N^.Next, except that the Next field
of the last node points to the first node in the list.
function Prev(N: NodePtr): NodePtr;
Returns a pointer to the node before N, or NIL if N is the
first node. This corresponmds to N^.Prev, except that the Prev
method of the first node will return the last node in the list.
function Empty: Boolean;
Returns True if the list is empty, else returns False.
STREAM I/O ROUTINES
procedure Store(var S: Stream);
Stores the list on a stream. The types of all nodes of the list
must have been registered with the stream. The list is stored
by applying S.Put to each node in the list, followed by an
S.Put(NIL).
procedure Load(var S: Stream);
Loads the list from a stream. The types of all nodes of the
list to be loaded must have been registered with the stream.
The list is loaded by appending the result of S.Get until S.Get
returns NIL.
ODEMO.PAS - AN EXAMPLE THAT USES STREAMS AND LISTS
--------------------------------------------------
The ODemo program demonstrates input and output of polymorphic
objects using a stream. A list of IntNode and StrNode objects is
created, written to a file, deleted, and finally reloaded from
the file. Notice how the list is built using the List type from
the Objects unit.
FORMS.PAS - IMPLEMENTS A FORM ENTRY AND EDIT OBJECT
---------------------------------------------------
The Forms unit implements two basic object types: Field and Form.
A Field represents a data entry field, and a Form represents a
collection of Fields which add up to a complete data entry form.
A number of field types are implemented by the Forms unit. Viewed
as a whole, they form the following hierarchy:
Field (Abstract field type)
ÀÄÄÄÄÄÄÄFText (Abstract text field)
ÃÄÄÄÄÄÄÄFStr (String field)
ÀÄÄÄÄÄÄÄFNum (Abstract numeric field)
ÃÄÄÄÄÄÄÄFInt (Integer field)
³ ÀÄÄÄÄÄÄÄFZip (Zipcode field)
ÀÄÄÄÄÄÄÄFReal (Floating point field)
The basic Field type defines the common properties of all fields.
It is an abstract type, which exists only so that other field
types can inherit from it. Instances of type Field are never
actually created. Field is derived from Node (defined in the
Objects unit), so that fields can be put on a linked list that
makes up a data entry form. The data fields of type Field are:
X X coordinate in the form.
Y Y coordinate in the form.
Size Size of the data stored in the field.
Title Pointer to a title string.
Value Pointer to current value (Size bytes long).
Extra Marks location of fields defined in descendant types.
The methods of a Field are:
Init Allocates and initializes a field.
Load Loads a field from a stream.
Done Cleans up and disposes a field.
Clear Sets a field to its default value.
Edit Edits a field and returns termination character.
Show Displays a field.
Store Stores a field on a stream.
The FText type is an abstract type which serves as the ancestor
of all text field types. It defines two "helper" methods, GetStr
and PutStr, and implements code for the Edit and Show methods.
GetStr converts a field's value to a string. PutStr converts a
string and stores it as the field's value. PutStr returns True if
the string represents a valid value; else it returns false and
leaves the field's value unchanged.
The FStr type implements a String field with a user defined
maximum length.
The FNum type is the abstract ancestor type of all numeric
fields. It changes the Show method to right justify the value
when it is displayed.
The FInt type implements a Longint field with user defined upper
and lower bounds.
The FZip type implements a zipcode field, which essentially is a
5-digit FInt field that gets left-padded with zeros when
displayed.
The FReal type implements a floating point value field with a
user defined total width and number of decimals.
The Form type defines a form, which primarily is a collection of
fields kept on a list. The data fields of type Form are:
X1 Left coordinate of Form window.
Y1 Top coordinate of Form window.
X2 Right coordinate of Form window.
Y2 Bottom coordinate of Form window.
Size Total size of data in the form. This is the sum of
the Size fields of each field on the Fields list.
Fields List of Field objects.
The methods of a Form are:
Init Allocates and initializes a form.
Load Loads a form from a stream.
Done Cleans up and disposes a form.
Edit Edits a form and returns termination character.
Show Displays a form, optionally first erasing the window.
Add Adds a field to a form.
Clear Sets all fields to their default values.
Get Copies a form into a variable.
Put Copies a variable into a form.
Store Stores a form on a stream.
The fields in a form a kept on a linked list, which is managed by
the List type in the Objects unit. Notice how the Edit, Show,
Clear, Get, and Put methods use typecasts to promote the nodes of
the list from type Node to type Field (a descendant of Node). The
Form object "knows" that the entries on the field list are always
of type Field, and can therefore safely promote them.
The Get and Put methods are used to copy data into and out of a
form. A variable specified as a parameter to Get or Put must be
record with fields that correspond in order, type, and size to
the fields of the form.
The FStream type implements a buffered stream that knows the
FStr, FInt, FZip, and FReal types. Notice how only the
RegisterTypes method is overridden, and how it first calls the
inherited RegisterTypes before registering any new types.
SLIDERS.PAS - IMPLEMENTS A SLIDER FIELD
---------------------------------------
The Sliders unit implements a new Field type, called FSlider, for
use with the Forms unit. Contrary to the text field types
implemented by the Forms unit, a slider shows and edits itself as
a scroll-bar like control with a knob that indicates the current
value. The FSlider type is a direct descendant of the Field type.
The current slider value, and the minimum, maximum, and delta
values of the slider are stored as 16-bit integers.
In addition to the FSlider type, the Sliders unit defines a new
FStream type. It is a direct descendant of the FStream type in
Forms (notice how the same name can be used in two different
units). Sliders.FStream differs from Forms.FStream only in the
RegisterTypes method, which adds registration of the FSlider
type; this is required so that sliders can be stored on and
loaded from streams along with other field types.
FDEMO.PAS - A SIMPLE FORMS EDITOR EXAMPLE
-----------------------------------------
The FDemo program uses the Forms and Sliders unit to implement a
simple forms editor program, which lets you edit a record using a
form. Notice how the fields in a Person record correspond in
order, type, and size to the fields in the form. The Form.Put and
Form.Get methods require this one-to-one mapping in order to work
correctly.
CARDS.PAS - IMPLEMENTS A CARD FILE OBJECT
-----------------------------------------
The Cards unit implements a Rolodex-like card file object. The
cards are kept on a doubly-linked list which can be traversed
using the Next and Prev methods.
The Insert and Delete methods allow insertion and deletion at the
current location in the card list. The current location is a
state variable maintained by the CardList object.
CARDFILE.PAS - A SIMPLE CARD FILER APPLCIATION
----------------------------------------------
The CardFile program implements a simple card filer application.
It takes a card file name as a command-line argument, loads that
file, and allows you to scroll through and edit it. A card file
contains a saved Form object followed by a saved CardList object.
The CardFile application is not limited to a specific form
layout--the form is loaded from the a disk file rather than being
statically built in CARDFILE.PAS.
A sample card file, CARDS.DTA, is provided on the disk. To run
the card filer with that file, use the command line:
CARDFILE CARDS.DTA
CARDGEN.PAS - CARD FILER FORMS GENERATOR
----------------------------------------
CARDGEN.PAS is a sample program that defines two forms and saves
them in disk files that can be edited using CARDFILE.PAS. If you
run CARDGEN.PAS, it will create new PARTS.DTA and PEOPLE.DTA
files (and thus overwrite any existing files with those names, so
beware).


BIN
Borland Turbo Pascal v55/OVRDEMO.OVR Normal file
View File

Binary file not shown.

53
Borland Turbo Pascal v55/OVRDEMO.PAS Normal file
View File

@ -0,0 +1,53 @@
{ Turbo Overlays }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
{$F+,O+}
program OvrDemo;
(*
This is a simple example of how to use the new overlay system. For
more complete documentation, refer to the overlay chapter in the
Turbo Pascal manual. Here's a quick checklist:
1. Turn "far calls" on {$F+} (to be safe, in all overlaid units and
the main program).
2. Turn "Overlays allowed" on {$O+}
3. Use Overlay unit in main program.
4. Issue separate {$O} directives for each overlaid unit.
5. Make sure to call OvrInit and pass the name of the .OVR file.
6. Test OvrResult after OvrInit calls (optional).
7. Compile to disk (cannot run in memory).
Here the overlay error returns for quick reference:
const
ovrOk = 0; { Success }
ovrError = -1; { Overlay manager error }
ovrNotFound = -2; { Overlay file not found }
ovrNoMemory = -3; { Not enough memory for overlay buffer }
ovrIOError = -4; { Overlay file I/O error }
ovrNoEMSDriver = -5; { EMS driver not installed }
ovrNoEMSMemory = -6; { Not enough EMS memory }
*)
uses
Overlay, Crt, OvrDemo1, OvrDemo2;
{$O OvrDemo1} { overlay 'em }
{$O OvrDemo2}
begin
TextAttr := White;
ClrScr;
OvrInit('OVRDEMO.OVR'); { init overlay system, reserve heap space }
if OvrResult <> 0 then
begin
Writeln('Overlay error: ', OvrResult);
Halt(1);
end;
repeat
Write1;
Write2;
until KeyPressed;
end.


20
Borland Turbo Pascal v55/OVRDEMO1.PAS Normal file
View File

@ -0,0 +1,20 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
{$O+,F+}
unit OvrDemo1;
{ This unit is used by OVRDEMO.PAS }
interface
procedure Write1;
implementation
procedure Write1;
begin
Writeln('One...');
end;
end.


BIN
Borland Turbo Pascal v55/OVRDEMO1.TPU Normal file
View File

Binary file not shown.

20
Borland Turbo Pascal v55/OVRDEMO2.PAS Normal file
View File

@ -0,0 +1,20 @@
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
{$O+,F+}
unit OvrDemo2;
{ This unit is used by OVRDEMO.PAS }
interface
procedure Write2;
implementation
procedure Write2;
begin
Writeln('Two...');
end;
end.


BIN
Borland Turbo Pascal v55/OVRDEMO2.TPU Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v55/PC3270.BGI Normal file
View File

Binary file not shown.

88
Borland Turbo Pascal v55/POINTS.PAS Normal file
View File

@ -0,0 +1,88 @@
{ Turbo Points }
{ Copyright (c) 1989 by Borland Interational, Inc. }
unit Points;
{ From P-20 of the Object-Oriented Programming Guide.
}
interface
uses Graph;
type
Location = object
X,Y : Integer;
procedure Init(InitX, InitY : Integer);
function GetX : Integer;
function GetY : Integer;
end;
Point = object (Location)
Visible : Boolean;
procedure Init(InitX, InitY : Integer);
procedure Show;
procedure Hide;
function IsVisible : Boolean;
procedure MoveTo(NewX, NewY : Integer);
end;
implementation
{--------------------------------------------------------}
{ Location's method implementations: }
{--------------------------------------------------------}
procedure Location.Init(InitX, InitY : Integer);
begin
X := InitX;
Y := InitY;
end;
function Location.GetX : Integer;
begin
GetX := X;
end;
function Location.GetY : Integer;
begin
GetY := Y;
end;
{--------------------------------------------------------}
{ Points's method implementations: }
{--------------------------------------------------------}
procedure Point.Init(InitX, InitY : Integer);
begin
Location.Init(InitX, InitY);
Visible := False;
end;
procedure Point.Show;
begin
Visible := True;
PutPixel(X, Y, GetColor);
end;
procedure Point.Hide;
begin
Visible := False;
PutPixel(X, Y, GetBkColor);
end;
function Point.IsVisible : Boolean;
begin
IsVisible := Visible;
end;
procedure Point.MoveTo(NewX, NewY : Integer);
begin
Hide;
Location.Init(NewX, NewY);
Show;
end;
end.


43
Borland Turbo Pascal v55/PROCVAR.PAS Normal file
View File

@ -0,0 +1,43 @@
{ Copyright (c) 1988, 1989 by Borland International, Inc. }
{$F+}
program ProcVar;
{ For an extensive discussion of procedural types, variables and
parameters, refer to Chapter 8 in the Turbo Pascal Reference
Guide (or Chapter 7 in the Turbo Pascal 5.0 Update manual).
}
type
IntFuncType = function (x, y : integer) : integer; { No func. identifier }
var
IntFuncVar : IntFuncType;
procedure DoSomething(Func : IntFuncType; x, y : integer);
begin
Writeln(Func(x, y):5); { call the function parameter }
end;
function AddEm(x, y : integer) : integer;
begin
AddEm := x + y;
end;
function SubEm(x, y : integer) : integer;
begin
SubEm := x - y;
end;
begin
{ Directly: }
DoSomething(AddEm, 1, 2);
DoSomething(SubEm, 1, 2);
{ Indirectly: }
IntFuncVar := AddEm; { an assignment, not a call }
DoSomething(IntFuncVar, 3, 4); { a call }
IntFuncVar := SubEm; { an assignment, not a call }
DoSomething(IntFuncVar, 3, 4); { a call }
end.


67
Borland Turbo Pascal v55/QSORT.PAS Normal file
View File

@ -0,0 +1,67 @@
{ Turbo Sort }
{ Copyright (c) 1985, 1989 by Borland International, Inc. }
program qsort;
{$R-,S-}
uses Crt;
{ This program demonstrates the quicksort algorithm, which }
{ provides an extremely efficient method of sorting arrays in }
{ memory. The program generates a list of 1000 random numbers }
{ between 0 and 29999, and then sorts them using the QUICKSORT }
{ procedure. Finally, the sorted list is output on the screen. }
{ Note that stack and range checks are turned off (through the }
{ compiler directive above) to optimize execution speed. }
const
max = 1000;
type
list = array[1..max] of integer;
var
data: list;
i: integer;
{ QUICKSORT sorts elements in the array A with indices between }
{ LO and HI (both inclusive). Note that the QUICKSORT proce- }
{ dure provides only an "interface" to the program. The actual }
{ processing takes place in the SORT procedure, which executes }
{ itself recursively. }
procedure quicksort(var a: list; Lo,Hi: integer);
procedure sort(l,r: integer);
var
i,j,x,y: integer;
begin
i:=l; j:=r; x:=a[(l+r) DIV 2];
repeat
while a[i]<x do i:=i+1;
while x<a[j] do j:=j-1;
if i<=j then
begin
y:=a[i]; a[i]:=a[j]; a[j]:=y;
i:=i+1; j:=j-1;
end;
until i>j;
if l<j then sort(l,j);
if i<r then sort(i,r);
end;
begin {quicksort};
sort(Lo,Hi);
end;
begin {qsort}
Write('Now generating 1000 random numbers...');
Randomize;
for i:=1 to max do data[i]:=Random(30000);
Writeln;
Write('Now sorting random numbers...');
quicksort(data,1,max);
Writeln;
for i:=1 to 1000 do Write(data[i]:8);
end.


285
Borland Turbo Pascal v55/README Normal file
View File

@ -0,0 +1,285 @@
WELCOME TO TURBO PASCAL 5.5
---------------------------
This README file contains important, last minute information
about Turbo Pascal 5.5. The HELPME!.DOC file also answers many
common Technical Support questions.
TABLE OF CONTENTS
-----------------
1. Turbo Debugger
2. Important Notes & Additions
3. Tour - New introduction to the IDE
4. Corrections to the manual
5. Turbo Pascal 5.5 and the Toolboxes
6. Listing of Files on the Disks
1. TURBO DEBUGGER
-----------------
Turbo Debugger has been upgraded to version 1.5 to support
Turbo Pascal 5.5's object-oriented extensions. You can debug
both 5.0 and 5.5 programs with the new release of TD (1.5). If
you have TD 1.0, you can still debug any TP 5.5 programs that
do not use objects.
If you don't already have Turbo Debugger 1.5, call Customer
Service for information about upgrading: (408) 438-5300.
2. IMPORTANT NOTES & ADDITIONS
------------------------------
o REBUILD TPUs. Remember to rebuild your old units with version
5.5 or you'll get an error 72 (Unit file format error) when you
try to use that unit. To rebuild an entire program from the
Integrated Development Environment, load the main program into
the editor and select the COMPILE/BUILD menu command. If you
are using the command-line compiler, type:
tpc /b ProgramName
You'll need to have all source code available in the logged
directory or in the OPTIONS\DIRECTORY\UNIT DIRECTORY path.
o COMPILER ERROR MESSAGES. The following compiler error
messages have been added or modified:
99 File and procedure types are not allowed here
146 File access denied
o RUN-TIME ERROR MESSAGE. The following new run-time error
message will occur if range-checking is on {$R+} and a call is
made to an object's virtual method when that object has not yet
been initialized via a constructor call (see Page 37 in the
Object-Oriented Programming Guide for more information):
210 Object not initialized
3. TOUR - NEW INTRODUCTION TO THE IDE
-------------------------------------
Version 5.5 now includes Tour, an online introduction to the
Integrated Development Environment (IDE). If you are new to
Turbo Pascal, spending 15 minutes with Tour will get you up to
speed in the IDE.
4. CORRECTIONS TO THE OOP GUIDE
-------------------------------
o Page 3: The reference to using TINST at the bottom of the page
should indicate Page 308 of the User's Guide.
o Page 94: To perform more complete error checking in the
code fragment at the top of the page, insert a conditional
statement immediately after the OverInitEMS call:
...
OvrInitEMS;
if (OvrResult = OvrOK) then
begin
SaveOvrRead := OvrReadBuf; { Save EMS default }
OvrReadBuf := MyOvrRead; { Install ours }
UsingEMS := true;
end;
o Page 114 - 118: Corrections or Additions to the Index
extensibility 46,78
Fail 107
with (reserved word)
statement 13,22,78,82
implicit 17
5. TURBO PASCAL 5.5 AND THE TOOLBOXES
-------------------------------------
The source code from version 4.0 of all Turbo Pascal toolboxes
(including the Turbo Pascal Tutor) is fully compatible with 5.5.
6. LIST OF FILES ON THE DISKS
-----------------------------
INSTALL/COMPILER/TOUR/ONLINE HELP
---------------------------------
INSTALL EXE - Installs Turbo Pascal on your system
README COM - Program to display README file
TURBO EXE - Turbo Pascal Integrated Development Environment
TURBO TPL - Resident units for Turbo Pascal
TPC EXE - Command-line version of Turbo Pascal
UNPACK COM - Unpacks .ARC files
HELP ARC - Archived Turbo Pascal Help File (TURBO.HLP)
TOUR ARC - Archived Tour of the Integrated
Development Environment
TOUR EXE - Tour program
TPTOUR1 CBT - Tour data file
TPTOUR2 CBT - Tour data file
THELP COM - Memory-resident help program so you can get
Online Help even if you are not working in the
Integrated Development Environment.
README - This file!
OOP/DEMOS/BGI/DOC/UTILITIES/MISC
--------------------------------
OOPDEMOS ARC - Packed file that contains object-oriented
programming (OOP) examples
OOPDEMOS DOC - Documentation overview of OOP examples
ODEMO PAS - Example for OBJECTS.PAS
OBJECTS PAS - OOP unit that defines some basic object types
BUFSTM ASM - Assembler code for OBJECTS.PAS
DOSSTM ASM - Assembler code for OBJECTS.PAS
STREAM ASM - Assembler code for OBJECTS.PAS
OBJECTS INC - Assembler code for OBJECTS.PAS
DOSSTM OBJ - .OBJ file for OBJECTS.PAS
BUFSTM OBJ - .OBJ file for OBJECTS.PAS
STREAM OBJ - .OBJ file for OBJECTS.PAS
FDEMO PAS - Example for FORMS.PAS, SLIDERS.PAS
FORMS PAS - OOP forms entry/edit unit
SLIDERS PAS - OOP unit that extends FORMS.PAS
CARDFILE PAS - Database example for CARDS.PAS
CARDS DTA - Example data for CARDFILE.PAS
CARDS PAS - OOP unit that implements cards database
CARDGEN PAS - Generates example databases for CARDFILE.PAS
BREAKOUT PAS - OOP game example
BOUNDS PAS - OOP unit for Breakout demo
BRICKS PAS - OOP unit for Breakout demo
WALLS PAS - OOP unit for Breakout demo
COUNT PAS - OOP unit for Breakout demo
SCREEN PAS - OOP unit for Breakout demo
POINTS PAS - From page 20 of the OOP Guide
FIGURES PAS - From page 42 of the OOP Guide
FIGDEMO PAS - From page 47 of the OOP Guide
LISTDEMO PAS - From page 57 of the OOP Guide
TCALC ARC - Packed file with complete source code to
new object-oriented Turbo Calc example program
TCALC PAS - Turbo Calc example program
TCALC DOC - Documentation for TCALC demo
TCCELL PAS - OOP unit for TCALC demo
TCCELLSP PAS - OOP unit for TCALC demo
TCHASH PAS - OOP unit for TCALC demo
TCINPUT PAS - OOP unit for TCALC demo
TCLSTR PAS - OOP unit for TCALC demo
TCMENU PAS - OOP unit for TCALC demo
TCPARSER PAS - OOP unit for TCALC demo
TCRUN PAS - OOP unit for TCALC demo
TCSCREEN PAS - OOP unit for TCALC demo
TCSHEET PAS - OOP unit for TCALC demo
TCUTIL PAS - OOP unit for TCALC demo
TCCOMPAR ASM - Assembler code for TCALC demo
TCMVSMEM ASM - Assembler code for TCALC demo
TCCOMPAR OBJ - .OBJ file for TCALC demo
TCMVSMEM OBJ - .OBJ file for TCALC demo
DEMOS ARC - Packed file that contains example (non-object
oriented) programs
WINDEMO PAS - WIN.PAS demo
WIN PAS - Simple windowing extensions to Crt unit
WIN ASM - Assembler code for WIN.PAS
WIN OBJ - .OBJ file for WIN.PAS
EXECDEMO PAS - Executes a child program (DOS unit)
DIRDEMO PAS - Displays directory, uses procedural types
CRTDEMO PAS - Crt unit demo
OVRDEMO PAS - Overlay unit demo
OVRDEMO1 PAS - Example unit for OVRDEMO.PAS
OVRDEMO2 PAS - Example unit for OVRDEMO.PAS
CIRCULAR PAS - Demos the USES clause in implementation section
DISPLAY PAS - Example unit for CIRCULAR.PAS
ERROR PAS - Example unit for CIRCULAR.PAS
QSORT PAS - QuickSort example
LISTER PAS - Printer unit demo
HILB PAS - Floating-point demo
FIB8087 PAS - Recursive example that uses the 8087 math
coprocessor and avoids 8087 stack overflow
PROCVAR PAS - Simple procedural types demo
EMS PAS - Example program that shows how to use expanded
memory from your programs
CPASDEMO PAS - Example program that shows how to link TURBO C .OBJ
files into Turbo Pascal programs
CPASDEMO C - C program for use with CPASDEMO.PAS
CTOPAS TC - Turbo C configuration file to use with TC.EXE
for producing .OBJ files that can be linked with
Turbo Pascal (see CPASDEMO.PAS)
TURBOC CFG - Turbo C configuration file to use with TCC.EXE for
producing .OBJ files that can be linked with Turbo
Pascal (see CPASDEMO.PAS)
BGI ARC - Packed file that contains graphics documentation,
drivers, fonts, and examples
GRAPH TPU - Borland Graphics Interface (BGI) Graph unit
ATT BGI - Graphics device driver for AT&T 6300
CGA BGI - Graphics device driver for CGA and MCGA
EGAVGA BGI - Graphics device driver for EGA and VGA
HERC BGI - Graphics device driver for Hercules mono
PC3270 BGI - Graphics device driver for 3270 PC
IBM8514 BGI - Graphics device driver for IBM 8514
GOTH CHR - Gothic font character set
LITT CHR - Small font character set
SANS CHR - Sans serif font character set
TRIP CHR - Triplex font character set
BGIDEMO PAS - Graph unit example
ARTY PAS - Graph unit example
BGILINK PAS - Graph unit example that shows how to link
font and driver files into an .EXE file
DRIVERS PAS - Example unit for use with BGILINK.PAS
FONTS PAS - Example unit for use with BGILINK.PAS
BGILINK MAK - Make file for use with BGILINK.PAS
DOC ARC - Interface section listings for system units
THELP DOC - Documentation for memory-resident help utility
SYSTEM DOC - Interface section listing for the System unit
DOS DOC - Interface section listing for the Dos unit
CRT DOC - Interface section listing for the Crt unit
PRINTER DOC - Interface section listing for the Printer unit
OVERLAY DOC - Interface section listing for the Overlay unit
GRAPH DOC - Interface section listing for the Graph unit
TURBO3 DOC - Interface section listing for the Turbo3 unit
GRAPH3 DOC - Interface section listing for the Graph3 unit
HELPME! DOC - Text file with the answers to many common
questions. If you have a technical question
about Turbo Pascal, chances are good that the
question and answer are in HELPME!.DOC.
TINSTXFR EXE - Transfers 4.0 and 5.0 IDE customizations to 5.5
UTILS ARC - Packed file that contains a number of useful
utilities
TINST EXE - Customization program for TURBO.EXE
MAKE EXE - Manages projects
GREP COM - Searches text files for strings
TOUCH COM - Changes a file's timestamp to force re-compilation
BINOBJ EXE - Converts a binary data file to an .OBJ file
TPUMOVER EXE - Unit mover utility
TPCONFIG EXE - Converts .TP files to .CFG
TURBO3 ARC - Turbo 3.0 compatibility files
UPGRADE EXE - Program that converts 3.0 programs to 5.5
UPGRADE DTA - Data file for UPGRADE.EXE
TURBO3 TPU - TURBO3 compatibility unit
GRAPH3 TPU - GRAPH3 compatibility unit (turtle graphics)
BCD PAS - Unit to convert Turbo Pascal 3.0 BCD reals to
Turbo Pascal 5.5 floating point numbers


BIN
Borland Turbo Pascal v55/README.COM Normal file
View File

Binary file not shown.

BIN
Borland Turbo Pascal v55/SANS.CHR Normal file
View File

Binary file not shown.

200
Borland Turbo Pascal v55/SCREEN.PAS Normal file
View File

@ -0,0 +1,200 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit Screen;
{ Turbo Pascal 5.5 object-oriented example.
See BREAKOUT.PAS.
This unit provides several objects for dealing with the screen.
}
interface
uses Crt, Dos;
type
Location = object
X, Y : Integer;
Visible : Boolean;
constructor Init(InitX, InitY : Integer);
procedure Relocate(NewX, NewY : Integer);
procedure MoveTo(NewX, NewY : Integer); virtual;
procedure Show; virtual;
procedure Hide; virtual;
function GetX : Integer;
function GetY : Integer;
function IsVisible : Boolean;
end;
Cursor = object(Location)
OldCursor : Integer;
TempCursor : Integer;
constructor Init;
procedure Show; virtual;
procedure Hide; virtual;
procedure SetCursor(NewCursor : Integer);
function GetCursor : Integer;
procedure MoveTo(NewX, NewY : Integer); virtual;
procedure Save;
procedure Restore;
procedure Speedup;
procedure Slowdown;
end;
SaveScreen = object(Cursor)
OldAttr : Byte;
constructor Init;
procedure Save;
procedure Restore;
end;
implementation
procedure SetCursorSpeed(NewSpeed : Word);
begin
Port[$60] := $F3;
Delay(200);
Port[$60] := NewSpeed;
end;
constructor Location.Init(InitX, InitY : Integer);
begin
X := InitX;
Y := InitY;
Visible := False;
end;
procedure Location.Relocate(NewX, NewY : Integer);
begin
X := NewX;
Y := NewY;
end;
procedure Location.MoveTo(NewX, NewY : Integer);
var
Vis : Boolean;
begin
Vis := Visible;
if Vis then Hide;
X := NewX;
Y := NewY;
if Vis then Show;
end;
procedure Location.Show;
begin
Visible := True;
end;
procedure Location.Hide;
begin
Visible := False;
end;
function Location.GetX : Integer;
begin
GetX := X;
end;
function Location.GetY : Integer;
begin
GetY := Y;
end;
function Location.IsVisible;
begin
IsVisible := Visible;
end;
constructor Cursor.Init;
begin
Location.Init(WhereX, WhereY);
OldCursor := GetCursor;
Location.Show;
end;
procedure Cursor.Show;
begin
SetCursor(TempCursor);
end;
procedure Cursor.Hide;
begin
TempCursor := GetCursor;
SetCursor($2000);
end;
function Cursor.GetCursor : Integer;
var
Reg : Registers;
begin
with Reg do
begin
AH := 3;
BH := 0;
Intr($10, Reg);
GetCursor := CX;
end;
end;
procedure Cursor.SetCursor(NewCursor : Integer);
var
Reg : Registers;
begin
with Reg do
begin
AH := 1;
BH := 0;
CX := NewCursor;
Intr($10, Reg);
end;
end;
procedure Cursor.MoveTo(NewX, NewY : Integer);
begin
Location.Relocate(NewX, NewY);
GoToXY(NewX, NewY);
end;
procedure Cursor.Save;
begin
Location.Relocate(WhereX, WhereY);
OldCursor := GetCursor;
end;
procedure Cursor.Restore;
begin
SetCursor(OldCursor);
GoToXY(X, Y);
end;
procedure Cursor.Speedup;
begin
SetCursorSpeed(0);
end;
procedure Cursor.Slowdown;
begin
SetCursorSpeed($2C);
end;
constructor SaveScreen.Init;
begin
Cursor.Init;
OldAttr := TextAttr;
end;
procedure SaveScreen.Save;
begin
Cursor.Save;
OldAttr := TextAttr;
end;
procedure SaveScreen.Restore;
begin
Cursor.Restore;
TextAttr := OldAttr;
ClrScr;
end;
end.


31
Borland Turbo Pascal v55/SIEVE.PAS Normal file
View File

@ -0,0 +1,31 @@
program sieve;
const
size = 8190;
type
flagType = array[ 0..size ] of boolean;
var
i, k, prime, count, iter : integer;
flags : flagType;
begin
for iter := 1 to 10 do begin
count := 0;
for i := 0 to size do flags[ i ] := true;
for i := 0 to size do begin
if flags[ i ] then begin
prime := i + i + 3;
k := i + prime;
while k <= size do begin
flags[ k ] := false;
k := k + prime;
end;
count := count + 1;
end;
end;
end;
writeln( 'count of primes: ', count );
end.

111
Borland Turbo Pascal v55/SLIDERS.PAS Normal file
View File

@ -0,0 +1,111 @@
{ Turbo Sliders }
{ Copyright (c) 1989 by Borland International, Inc. }
unit Sliders;
{ Turbo Pascal 5.5 object-oriented example.
This unit extends FORM.PAS' Field object type.
Refer to OOPDEMOS.DOC for an overview of this unit.
}
{$S-}
interface
uses Forms;
type
FSliderPtr = ^FSlider;
FSlider = object(Field)
Min, Max, Delta: Integer;
constructor Init(PX, PY: Integer; PTitle: FString;
PMin, PMax, PDelta: Integer);
procedure Clear; virtual;
function Edit: Char; virtual;
procedure Show; virtual;
procedure Display(I: Integer);
end;
FStream = object(Forms.FStream)
procedure RegisterTypes; virtual;
end;
implementation
uses Crt;
{ FSlider }
constructor FSlider.Init(PX, PY: Integer; PTitle: FString;
PMin, PMax, PDelta: Integer);
begin
Field.Init(PX, PY, 2, PTitle);
Min := PMin;
Max := PMax;
Delta := PDelta;
end;
procedure FSlider.Clear;
begin
Integer(Value^) := (Max - Min) div 2;
end;
function FSlider.Edit: Char;
var
I: Integer;
Ch: Char;
Stop: Boolean;
begin
I := Integer(Value^);
Stop := False;
repeat
Display(I);
GotoXY(X + Length(Title^) + 1, Y);
Ch := ReadChar;
case Ch of
CLeft: if I > Min then Dec(I, Delta);
CRight: if I < Max then Inc(I, Delta);
CHome: I := Min;
CEnd: I := Max;
CUndo: I := Integer(Value^);
CEnter, CNext, CPrev, CSave, CEsc: Stop := True;
else
Beep;
end;
until Stop;
if Ch <> CEsc then Integer(Value^) := I;
Edit := Ch;
end;
procedure FSlider.Show;
begin
Display(Integer(Value^));
end;
procedure FSlider.Display(I: Integer);
var
Steps: Integer;
S: FString;
begin
Steps := (Max - Min) div Delta + 1;
S[0] := Chr(Steps);
FillChar(S[1], Steps, #176);
S[(I - Min) div Delta + 1] := #219;
GotoXY(X, Y);
Color(TitleColor);
Write(Title^);
Color(ValueColor);
Write(' ', Min, ' ', S, ' ', Max, ' ');
end;
{ FStream }
procedure FStream.RegisterTypes;
begin
Forms.FStream.RegisterTypes;
Register(TypeOf(FSlider), @FSlider.Store, @FSlider.Load);
end;
end.


144
Borland Turbo Pascal v55/STREAM.ASM Normal file
View File

@ -0,0 +1,144 @@
; Turbo Pascal 5.5 object-oriented example
; Assembler code for OBJECTS.PAS unit
; Copyright (c) 1989 by Borland International, Inc.
TITLE Stream
INCLUDE OBJECTS.INC
CODE SEGMENT BYTE PUBLIC
ASSUME CS:CODE
PUBLIC Stream@Get
Stream@Get PROC FAR
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
PUSH AX
MOV AX,SP
PUSH SS
PUSH AX
MOV AX,2
PUSH AX
LES DI,@Self
PUSH ES
PUSH DI
MOV DI,ES:[DI]
CALL [DI].Stream$Read
POP BX
OR BX,BX
JE @@2
LES DI,@Self
DEC BX
CMP BX,ES:[DI].Stream@TypeCount
JAE @@1
PUSH ES
PUSH DI
LES DI,ES:[DI].Stream@TypeList
SHL BX,1
PUSH WORD PTR ES:[DI+BX]
XOR AX,AX
PUSH AX
PUSH AX
LES DI,@Self
LES DI,ES:[DI].Stream@ProcList
SHL BX,1
SHL BX,1
CALL ES:[DI+BX].SProc@LoadProc
JMP SHORT @@3
@@1: MOV AX,-2
CALL StreamError
@@2: XOR AX,AX
MOV DX,AX
@@3: POP BP
RET 4
Stream@Get ENDP
PUBLIC Stream@Put
Stream@Put PROC FAR
@B EQU (DWORD PTR [BP+10])
@Self EQU (DWORD PTR [BP+6])
PUSH BP
MOV BP,SP
LES DI,@B
MOV CX,ES
OR CX,DI
JE @@1
MOV AX,ES:[DI]
LES DI,@Self
MOV CX,ES:[DI].Stream@TypeCount
JCXZ @@2
MOV BX,CX
LES DI,ES:[DI].Stream@TypeList
CLD
REPNE SCASW
JNE @@2
NEG CX
ADD CX,BX
@@1: PUSH CX
MOV AX,SP
PUSH SS
PUSH AX
MOV AX,2
PUSH AX
LES DI,@Self
PUSH ES
PUSH DI
MOV DI,ES:[DI]
CALL [DI].Stream$Write
POP BX
DEC BX
JS @@3
LES DI,@Self
PUSH ES
PUSH DI
PUSH @B.w2
PUSH @B.w0
LES DI,ES:[DI].Stream@ProcList
SHL BX,1
SHL BX,1
SHL BX,1
CALL ES:[DI+BX].SProc@StoreProc
JMP SHORT @@3
@@2: LES DI,@Self
MOV AX,-1
CALL StreamError
@@3: POP BP
RET 8
Stream@Put ENDP
; Stream error handler
; In AX = Error code
; ES:DI = Stream object pointer
; Uses AX,BX,CX,DX,SI
PUBLIC StreamError
StreamError PROC NEAR
PUSH ES
PUSH DI
PUSH AX
PUSH ES
PUSH DI
MOV DI,ES:[DI]
CALL [DI].Stream$Error
POP DI
POP ES
RET
StreamError ENDP
CODE ENDS
END


BIN
Borland Turbo Pascal v55/STREAM.OBJ Normal file
View File

Binary file not shown.

157
Borland Turbo Pascal v55/TCALC.DOC Normal file
View File

@ -0,0 +1,157 @@
Turbo Pascal 5.5
Turbo Calc Information
Build Information
-----------------
The following files are provided in TCALC.ARC and are required
in order to build TCALC.EXE:
TCALC PAS
TCCELL PAS
TCCELLSP PAS
TCHASH PAS
TCINPUT PAS
TCLSTR PAS
TCMENU PAS
TCPARSER PAS
TCRUN PAS
TCSCREEN PAS
TCSHEET PAS
TCUTIL PAS
TCCOMPAR OBJ
TCMVSMEM OBJ
In addition, TCALC uses the OBJECTS module contained in the
\TP\OOPDEMOS directory. Make sure OBJECTS.TPU is available (in
the TCALC directory or in the UNIT DIRECOTRY) when building
TCALC.
Types of Cells
--------------
Value: A number.
Text: A string - start it with a space to make sure that it
doesn't get parsed.
Formula: A string that is an expression (see explanation of
expressions below). This cell will be constantly updated (if
AutoCalc is on) to the current value of the expression.
Repeat: A cell with a character that will repeat indefinitely
across the spreadsheet. Type in the character that you want
to repeat with a leading backslash (example: type \_ to get
an underline across the screen).
General Information
-------------------
Columns range from A to CRXO (65535), and rows range from 1 to
65535.
The little dot in the upper left of a spreadsheet tells you
which of the spreadsheets is the current one. The number of the
spreadsheet is also printed, along with 'F' if formula display
is on and 'A' if AutoCalc is on.
The file that the spreadsheet will be saved to is listed at the
bottom of each spreadsheet, along with an asterisk if the
spreadsheet has been updated.
Expressions
-----------
Cell names in formulas are typed in with the column followed by
the row:
A1+A2
B6^5
To compute the sum of a group of cells, put a colon between the
first cell and the last cell in the group:
A1:A10 - Sum all of cells from A1 to A10 and puts the
result in the current cell.
A1:C10 - Sum of all of cells from A1 to A10, B1 to B10,
and C1 to C10 and puts the result in the current
cell.
Available Functions
-------------------
ABS - absolute value
ACOS - arc cosine
ASIN - arc sine
ATAN - arc tangent
COS - cosine
COSH - hyperbolic cosine
EXP - exponential function
LOG - logarithm
LOG10 - base 10 logarithm
POW10 - raise argument to the 10th power
ROUND - round to the nearest whole number
SIN - sine
SINH - hyperbolic sine
SQR - square
SQRT - square root
TAN - tangent
TANH - hyperbolic tangent
TRUNC - return the whole part of a number
Examples:
TRUNC(A1)
SQRT(SQR(34.5))
ABS(TRUNC(B16))
Shortcut Commands
-----------------
AltX - Quit
Ins - Turn block on and off
Del - Delete current cell
F2 - Save current spreadsheet
AltF2 - Save as
F3 - Replace current spreadsheet
AltF3 - Load new spreadsheet (opens up additional window)
F4 - Delete current spreadsheet
F6 - Next spreadsheet
F7 - Toggle formula display on/off
F8 - Toggle AutoCalc on/off
F9 - Recalc
F10 - Main menu
ASCII keys - Add cell
The Parser
----------
The state and goto information for the parser was created using
the UNIX YACC utility. The input to YACC was as follows:
%token CONST CELL FUNC
%%
e : e '+' t
| e '-' t
| t
;
t : t '*' f
| t '/' f
| f
;
f : x '^' f
| x
;
x : '-' u
| u
;
u : CELL ':' CELL
| o
;
o : CELL
| '(' e ')'
| CONST
| FUNC '(' e ')'
;
%%


18
Borland Turbo Pascal v55/TCALC.PAS Normal file
View File

@ -0,0 +1,18 @@
{ Turbo Calc }
{ Copyright (c) 1989 by Borland International, Inc. }
program TCalc;
{ Turbo Pascal 5.5 object-oriented example main module.
Object-oriented spreadsheet program.
See TCALC.DOC for more information about this example.
}
{$S-}
uses TCRun;
begin { Call main procedure. The program is designed this way to make }
Run; { compiles faster. Since the main source file gets compiled every }
end. { every time, it makes sense to make the file as small as possible. }


1926
Borland Turbo Pascal v55/TCCELL.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
Borland Turbo Pascal v55/TCCELL.TPU Normal file
View File

Binary file not shown.

228
Borland Turbo Pascal v55/TCCELLSP.PAS Normal file
View File

@ -0,0 +1,228 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit TCCellSp;
{ Turbo Pascal 5.5 object-oriented example cell support routines.
This unit is used by TCALC.PAS.
See TCALC.DOC for an more information about this example.
}
{$N+,S-}
interface
uses TCUtil, TCLStr, TCScreen, TCInput, TCCell;
function GetColumn(Prompt : String; MaxCols, ColSpace : Word) : Word;
function GetRow(Prompt : String; MaxRows : Word) : Word;
function GetCellPos(Prompt : String; MaxCols, MaxRows, ColSpace,
RowNumberSpace : Word; var P : CellPos) : Boolean;
function FormulaStart(Inp : LStringPtr; Start, MaxCols, MaxRows : Word;
var P : CellPos; var FormLen : Word) : Boolean;
procedure FixFormulaCol(CP : CellPtr; Diff : Longint;
MaxCols, MaxRows : Word);
procedure FixFormulaRow(CP : CellPtr; Diff : Longint;
MaxCols, MaxRows : Word);
implementation
function GetColumn(Prompt : String; MaxCols, ColSpace : Word) : Word;
{ Lets the user enter a column from the keyboard }
var
I : InputField;
S : String;
C : Word;
begin
with I do
begin
if not Init(Length(Prompt) + 3, 0, -1, ColSpace, AllUpper) then
begin
GetColumn := 0;
Exit;
end;
WriteXY(Prompt + ': ', 1, Pred(Scr.CurrRows), Colors.PromptColor);
repeat
Edit(0);
S := InputData^.ToString;
if (not GetQuit) and (S <> '') then
begin
C := StringToCol(S, MaxCols);
if C = 0 then
Scr.PrintError(ErrColumnError1 + ColToString(1) +
ErrColumnError2 + ColToString(MaxCols));
end
else
C := 0;
until (C <> 0) or (S = '');
InputArea.Clear;
Done;
end; { with }
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.BlankColor);
GetColumn := C;
end; { GetColumn }
function GetRow(Prompt : String; MaxRows : Word) : Word;
{ Lets the user enter a row from the keyboard }
var
R : Word;
Good : Boolean;
begin
R := GetNumber(Prompt, 1, MaxRows, Good);
if Good then
GetRow := R
else
GetRow := 0;
end; { GetRow }
function GetCellPos(Prompt : String; MaxCols, MaxRows, ColSpace,
RowNumberSpace : Word; var P : CellPos) : Boolean;
{ Lets the user enter a cell position from the keyboard }
var
I : InputField;
S : String;
FormLen : Word;
begin
GetCellPos := False;
with I do
begin
if not Init(Length(Prompt) + 3, 0, -1, Pred(ColSpace + RowNumberSpace),
AllUpper) then
Exit;
WriteXY(Prompt + ': ', 1, Pred(Scr.CurrRows), Colors.PromptColor);
repeat
Edit(0);
S := InputData^.ToString;
if (not GetQuit) and (S <> '') then
begin
if FormulaStart(InputData, 1, MaxCols, MaxRows, P, FormLen) then
GetCellPos := True
else
Scr.PrintError(ErrCellError);
end
else
FormLen := 0;
until (FormLen <> 0) or (S = '');
InputArea.Clear;
Done;
end; { with }
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.BlankColor);
end; { GetCellPos }
function FormulaStart(Inp : LStringPtr; Start, MaxCols, MaxRows : Word;
var P : CellPos; var FormLen : Word) : Boolean;
{ Checks to see if a place in a long string is the beginning of a formula }
var
Col, Row : Word;
CS : String[10];
RS : String[10];
begin
with Inp^ do
begin
FormulaStart := False;
FormLen := 0;
FillChar(P, SizeOf(P), 0);
CS := '';
while (Start <= Length) and (Data^[Start] in Letters) do
begin
CS := CS + Data^[Start];
Inc(Start);
end;
Col := StringToCol(CS, MaxCols);
if Col = 0 then
Exit;
RS := '';
while (Start <= Length) and (Data^[Start] in Numbers) do
begin
RS := RS + Data^[Start];
Inc(Start);
end;
Row := StringToRow(RS, MaxRows);
if Row = 0 then
Exit;
P.Col := Col;
P.Row := Row;
FormLen := System.Length(CS) + System.Length(RS);
FormulaStart := True;
end; { with }
end; { FormulaStart }
procedure FixFormulaCol(CP : CellPtr; Diff : Longint;
MaxCols, MaxRows : Word);
{ Adjusts a formula for a new column }
var
FormLen, Place, OldLen, NewLen : Word;
P : CellPos;
S : String[10];
Good : Boolean;
begin
with FormulaCellPtr(CP)^, GetFormula^ do
begin
Place := 1;
Good := True;
while Good and (Place <= Length) do
begin
if FormulaStart(GetFormula, Place, MaxCols, MaxRows, P, FormLen) then
begin
OldLen := System.Length(ColToString(P.Col));
S := ColToString(Longint(P.Col) + Diff);
NewLen := System.Length(S);
if NewLen > OldLen then
Good := Insert(FillString(NewLen - OldLen, ' '), Place)
else if NewLen < OldLen then
Delete(Place, OldLen - NewLen);
if Good then
begin
Move(S[1], Data^[Place], System.Length(S));
Inc(Place, FormLen + NewLen - OldLen);
end;
end
else
Inc(Place);
end;
end; { with }
end; { FixFormulaCol }
procedure FixFormulaRow(CP : CellPtr; Diff : Longint;
MaxCols, MaxRows : Word);
{ Adjusts a formula for a new row }
var
ColLen, FormLen, Place, OldLen, NewLen : Word;
P : CellPos;
S : String[10];
Good : Boolean;
begin
with FormulaCellPtr(CP)^, GetFormula^ do
begin
Place := 1;
Good := True;
while Good and (Place <= Length) do
begin
if FormulaStart(GetFormula, Place, MaxCols, MaxRows, P, FormLen) then
begin
OldLen := System.Length(RowToString(P.Row));
S := RowToString(P.Row + Diff);
NewLen := System.Length(S);
ColLen := System.Length(ColToString(P.Col));
if NewLen > OldLen then
Good := Insert(FillString(NewLen - OldLen, ' '), Place + ColLen)
else if NewLen < OldLen then
Delete(Place + ColLen, OldLen - NewLen);
if Good then
begin
Move(S[1], Data^[Place + ColLen], System.Length(S));
Inc(Place, FormLen + NewLen - OldLen);
end;
end
else
Inc(Place);
end;
end; { with }
end; { FixFormulaRow }
end.


BIN
Borland Turbo Pascal v55/TCCELLSP.TPU Normal file
View File

Binary file not shown.

41
Borland Turbo Pascal v55/TCCOMPAR.ASM Normal file
View File

@ -0,0 +1,41 @@
; Turbo Pascal 5.5 object-oriented example
; Assembler code for TCALC example
; Copyright (c) 1989 by Borland International, Inc.
MODEL TPASCAL
LOCALS
CODESEG
PUBLIC Compare
; function Compare(var Source, Dest; Len : Word) : Boolean;
;
; Compares two areas of memory to see if they are identical.
;
; Variables:
;
; Source : Far pointer to the location of the first area of memory.
; Dest : Far pointer to the location of the second area of memory.
; Len : The amount of memory to be compared in bytes.
Proc Compare Source : DWord, Dest : DWord, Len : Word
push ds ; Save DS
mov cx,[Len] ; Move Len to CX
jcxz @@0 ; Quit if Len = 0, returning True
lds si,[Source] ; Load source pointer into DS:SI
les di,[Dest] ; Load destination pointer into ES:DI
cld ; Set direction to forward
repz cmpsb ; Compare the two areas
jz @@0 ; Return True if the compare was completed
mov cl,1 ;
@@0:
mov al,cl ; If CL = 0, return True, otherwise return False
xor al,1
pop ds ; Restore DS
ret
EndP
End


BIN
Borland Turbo Pascal v55/TCCOMPAR.OBJ Normal file
View File

Binary file not shown.

262
Borland Turbo Pascal v55/TCHASH.PAS Normal file
View File

@ -0,0 +1,262 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit TCHash;
{ Turbo Pascal 5.5 object-oriented example hash tables.
This unit is used by TCALC.PAS.
See TCALC.DOC for an more information about this example.
}
{$S-}
interface
uses TCUtil;
{ This unit allows you to implement hash tables. Each hash table is composed
of a number of "buckets", each of which points to a linked list of data
entries. The bucket that a particular data entry goes into is determined
by the HashValue function. }
const
MaxBuckets = 1000;
MaxHashItemSize = 256;
type
BucketRange = 1..MaxBuckets;
HashItemSizeRange = 1..MaxHashItemSize;
HashItemData = array[0..Pred(MaxHashItemSize)] of Byte;
HashItemDataPtr = ^HashItemData;
HashItemPtr = ^HashItem;
HashItem = record
Next : HashItemPtr;
Data : HashItemData;
end;
HashItemArray = array[BucketRange] of HashItemPtr;
HashTable = object
Buckets : BucketRange;
Items : Longint;
CurrItem : HashItemPtr;
CurrBucket : BucketRange;
HashData : ^HashItemArray;
constructor Init(InitBuckets : BucketRange);
destructor Done;
function Add : Boolean;
procedure Delete(Deleted : Pointer);
function FirstItem : HashItemPtr;
function NextItem : HashItemPtr;
function Change : Boolean;
function Search : HashItemPtr;
function HashValue : Word; virtual;
function Found(Item : HashItemPtr) : Boolean; virtual;
procedure CreateItem(var Item : HashItemPtr); virtual;
function ItemSize : HashItemSizeRange; virtual;
function CurrItemSize(Item : HashItemPtr) : HashItemSizeRange; virtual;
end;
implementation
constructor HashTable.Init(InitBuckets : BucketRange);
{ Initialize a new hash table with a certain number of buckets }
begin
GetMem(HashData, InitBuckets * SizeOf(HashItemPtr));
if HashData = nil then
Fail;
Buckets := InitBuckets;
FillChar(HashData^, Buckets * SizeOf(HashItemPtr), 0);
Items := 0;
end; { HashTable.Init }
destructor HashTable.Done;
{ Removes a hash table from memory }
var
P, D : HashItemPtr;
Counter : Word;
begin
for Counter := 1 to Buckets do
begin
P := HashData^[Counter];
while P <> nil do
begin
D := P;
P := P^.Next;
FreeMem(D, CurrItemSize(D) + SizeOf(HashItemPtr));
end;
end;
FreeMem(HashData, Buckets * SizeOf(HashItemPtr));
end; { HashTable.Done }
function HashTable.Add : Boolean;
{ Adds a new item to a hash table }
var
H, A : HashItemPtr;
V : BucketRange;
begin
Add := False;
V := Succ(HashValue mod Buckets);
H := HashData^[V];
A := H;
while H <> nil do
begin
H := H^.Next;
if H <> nil then
A := H;
end;
if A = nil then { Item will be the first element in the list }
begin
GetMem(HashData^[V], ItemSize + SizeOf(HashItemPtr));
A := HashData^[V];
if A = nil then
Exit;
end
else begin { Add item and end of list }
GetMem(A^.Next, ItemSize + SizeOf(HashItemPtr));
if A^.Next = nil then
Exit;
A := A^.Next;
end;
CreateItem(A);
A^.Next := nil;
Inc(Items);
Add := True;
end; { HashTable.Add }
procedure HashTable.Delete(Deleted : Pointer);
{ Deletes an item from a hash table, and returns the deleted item }
var
H, D : HashItemPtr;
V : BucketRange;
begin
V := Succ(HashValue mod Buckets);
H := HashData^[V];
D := H;
while (H <> nil) and (not Found(H)) do
begin
H := H^.Next;
if not Found(H) then
D := H;
end;
if H = nil then { The item was not found }
begin
if Deleted <> nil then
FillChar(Deleted^, ItemSize, 0);
Exit;
end
else begin
if H = HashData^[V] then
HashData^[V] := HashData^[V]^.Next
else
D^.Next := H^.Next;
if Deleted <> nil then { Fill Deleted with the item's data }
Move(H^.Data, Deleted^, ItemSize);
FreeMem(H, CurrItemSize(H) + SizeOf(HashItemPtr));
end;
Dec(Items);
end; { HashTable.Delete }
function HashTable.FirstItem : HashItemPtr;
{ Returns the first item in a hash table. to find all of the items in a
hash table, call FirstItem to get the first one and then call NextItem to
get the rest }
var
Counter : Word;
begin
for Counter := 1 to Buckets do
begin
CurrBucket := Counter;
CurrItem := HashData^[Counter];
if CurrItem <> nil then
begin
FirstItem := CurrItem;
Exit;
end;
end;
FirstItem := nil;
end; { HashTable.FirstItem }
function HashTable.NextItem : HashItemPtr;
{ Returns the next item in a hash table - called after FirstItem }
begin
CurrItem := CurrItem^.Next;
if CurrItem <> nil then
begin
NextItem := CurrItem;
Exit;
end;
while CurrBucket < Buckets do
begin
Inc(CurrBucket);
CurrItem := HashData^[CurrBucket];
if CurrItem <> nil then
begin
NextItem := CurrItem;
Exit;
end;
end;
NextItem := nil;
end; { HashTable.NextItem }
function HashTable.Change : Boolean;
{ Changes the data of a hash item }
var
H : HashItemPtr;
begin
H := HashData^[Succ(HashValue mod Buckets)];
while (H <> nil) and (not Found(H)) do
H := H^.Next;
if H <> nil then
begin
CreateItem(H);
Change := True;
end
else
Change := Add;
end; { HashTable.Change }
function HashTable.Search : HashItemPtr;
{ Searches for a particular hash item }
var
H : HashItemPtr;
begin
H := HashData^[Succ(HashValue mod Buckets)];
while (H <> nil) and (not Found(H)) do
H := H^.Next;
Search := H;
end; { HashTable.Search }
function HashTable.HashValue : Word;
{ Returns a hash value - must be written by the user }
begin
Abstract('HashTable.HashValue');
end; { HashTable.HashValue }
function HashTable.Found(Item : HashItemPtr) : Boolean;
{ Returns a boolean value indicating whether the current hash item is the
one being searched for - must be written by the user }
begin
Abstract('HashTable.Found');
end; { HashTable.Found }
procedure HashTable.CreateItem(var Item : HashItemPtr);
{ Creates a hash item - must be written by the user }
begin
Abstract('HashTable.CreateItem');
end; { HashTable.CreateItem }
function HashTable.ItemSize : HashItemSizeRange;
{ Returns the size of a hash item. If the hash item size is variable, this
is based on whatever the item being searched for, added, or deleted is -
must be written by the user }
begin
Abstract('HashTable.ItemSize');
end; { HashTable.ItemSize }
function HashTable.CurrItemSize(Item : HashItemPtr) : HashItemSizeRange;
{ Returns the size of a particular item. This needs to be written only if
the size of hash items is variable (strings, etc.) }
begin
CurrItemSize := ItemSize;
end; { HashTable.CurrItemSize }
end.


BIN
Borland Turbo Pascal v55/TCHASH.TPU Normal file
View File

Binary file not shown.

334
Borland Turbo Pascal v55/TCINPUT.PAS Normal file
View File

@ -0,0 +1,334 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit TCInput;
{ Turbo Pascal 5.5 object-oriented example input routines.
This unit is used by TCALC.PAS.
See TCALC.DOC for an more information about this example.
}
{$S-}
interface
uses Crt, TCUtil, TCScreen, TCLStr;
const
LeftInputArrow = #17;
RightInputArrow = #16;
YesNo = 'Y/N';
LegalYesNo = ['Y', 'N'];
AllUpper = True;
NotUpper = False;
ErrNumberError1 = 'You must enter a number from ';
ErrNumberError2 = ' to ';
ErrColumnError1 = 'You must enter a column from ';
ErrColumnError2 = ' to ';
ErrCellError = 'You must enter a legal cell';
type
InputField = object
StartCol : ScreenColRange;
StopCol : Integer;
InputRow : Integer;
MaxInputLen : Word;
Quit : Boolean;
InputData : LStringPtr;
UCase : Boolean;
InputArea : ScreenArea;
constructor Init(C1 : ScreenColRange; C2 : Integer; R : Integer;
InitMaxInputLen : Word; InitUCase : Boolean);
destructor Done;
function GetQuit : Boolean;
procedure Edit(StartCursor : Word);
procedure ClearInput;
end;
function ReadString(Prompt : String; Len : Word;
var ESCPressed : Boolean) : String;
function GetLegalChar(Prompt : String; Legal : CharSet;
var ESCPressed : Boolean) : Char;
function GetYesNo(Prompt : String; var ESCPressed : Boolean) : Boolean;
function GetNumber(Prompt : String; Low, High : Longint;
var Result : Boolean) : Longint;
implementation
constructor InputField.Init(C1 : ScreenColRange; C2 : Integer; R : Integer;
InitMaxInputLen : Word; InitUCase : Boolean);
{ Sets up an input field }
begin
InputData := New(LStringPtr, Init);
if InputData = nil then
Fail;
StartCol := C1;
StopCol := C2;
InputRow := R;
if InitMaxInputLen = 0 then
MaxInputLen := 65521 { Maximum area that a pointer can allocate }
else
MaxInputLen := InitMaxInputLen;
UCase := InitUCase;
Quit := False;
end; { InputField.Init }
destructor InputField.Done;
{ Remove memory used by an input field }
begin
Dispose(InputData, Done);
end; { InputField.Done }
function InputField.GetQuit : Boolean;
{ Check to see if an input field has been exited with ESC }
begin
GetQuit := Quit;
end; { InputField.GetQuit }
procedure InputField.Edit(StartCursor : Word);
{ Edits the input field }
var
CursorPos, Start, Cursor : Word;
Ch : Word;
Good, InsMode, Finished : Boolean;
R : ScreenRowRange;
SCol, ECol, EndCol : ScreenColRange;
begin
with InputData^ do
begin
Quit := False;
SCol := StartCol; { Figure out where the field starts and stops }
if StopCol <= 0 then
EndCol := Scr.CurrCols + StopCol
else
EndCol := StopCol;
if InputRow <= 0 then
R := Scr.CurrRows + InputRow
else
R := InputRow;
if (R = Scr.CurrRows) and (ECol = Scr.CurrCols) then
Dec(EndCol);
ECol := EndCol;
InputArea.Init(SCol, R, ECol, R, Colors.InputColor);
InputArea.Clear;
if StartCursor = 0 then
CursorPos := Succ(Length)
else
CursorPos := StartCursor;
Finished := False;
InsMode := True;
Cursor := Scr.InsCursor;
Start := Max(Longint(CursorPos) - ECol - SCol + 2, 1);
repeat
if CursorPos > Length then
ECol := EndCol;
if (CursorPos < Start) or (CursorPos > Start + ECol - SCol) then
Start := Max(Longint(CursorPos) - ECol + SCol, 1);
if (Start = 2) and (SCol <> StartCol) then
begin
SCol := StartCol;
Start := 1;
end;
if Start > 1 then
begin
if SCol = StartCol then
begin
Inc(Start);
SCol := Succ(StartCol); { Text is off left side of line }
end;
end
else
SCol := StartCol;
if Length > Start + ECol - SCol then
begin
if ECol = EndCol then
begin
if SCol <> StartCol then
Inc(Start);
ECol := Pred(EndCol); { Text is off right side of line }
end;
end
else
ECol := EndCol;
GotoXY(StartCol, R);
if SCol <> StartCol then { Text is off left side of line }
WriteColor(LeftInputArrow, Colors.InputArrowColor);
WriteColor(LeftJustStr(InputData^.Copy(Start, Succ(ECol - SCol)),
Succ(ECol - SCol)), Colors.InputColor);
if ECol <> EndCol then { Text is off right side of line }
WriteColor(RightInputArrow, Colors.InputArrowColor);
GotoXY(CursorPos - Start + SCol, R);
SetCursor(Cursor);
Ch := GetKey;
SetCursor(NoCursor);
case Ch of
Ord(' ')..Ord('~') : begin
if not (InsMode and (Length = MaxInputLen)) then
begin
if UCase then
Ch := Ord(UpCase(Chr(Ch)));
if InsMode or (CursorPos > Length) then
Good := Insert(Chr(Ch), CursorPos)
else begin
Good := True;
Change(Chr(Ch), CursorPos);
end;
if Good then
Inc(CursorPos);
end;
end;
HomeKey : CursorPos := 1;
EndKey : CursorPos := Succ(Length);
BS : begin
if CursorPos > 1 then
begin
Delete(Pred(CursorPos), 1);
Dec(CursorPos);
end;
end;
DelKey : begin
if CursorPos <= Length then
Delete(CursorPos, 1);
end;
LeftKey : begin
if CursorPos > 1 then
Dec(CursorPos);
end;
RightKey : begin
if CursorPos <= Length then
Inc(CursorPos);
end;
InsKey : begin
InsMode := not InsMode;
if InsMode then
Cursor := Scr.InsCursor
else
Cursor := Scr.OldCursor;
end;
CtrlLeftKey : begin { Move back one word }
if (CursorPos > 1) and (Data^[CursorPos] <> ' ') then
Dec(CursorPos);
while (CursorPos > 1) and (Data^[CursorPos] = ' ') do
Dec(CursorPos);
while (CursorPos > 1) and (Data^[Pred(CursorPos)] <> ' ') do
Dec(CursorPos);
end;
CtrlRightKey : begin { Move forward one word }
while (CursorPos <= Length) and (Data^[CursorPos] <> ' ') do
Inc(CursorPos);
while (CursorPos <= Length) and (Data^[CursorPos] = ' ') do
Inc(CursorPos);
end;
ESC : begin
ClearInput;
Quit := True;
Finished := True;
end;
CR : Finished := True;
end; { case }
until Finished;
end; { with }
end; { InputField.Edit }
procedure InputField.ClearInput;
{ Makes the input field data a null long string }
var
Good : Boolean;
begin
Good := InputData^.FromString('');
end; { InputField.ClearInput }
function ReadString(Prompt : String; Len : Word;
var ESCPressed : Boolean) : String;
{ Read a string from the input area }
var
I : InputField;
begin
with I do
begin
if not Init(Length(Prompt) + 3, 0, -1, Len, NotUpper) then
begin
ESCPressed := True;
ReadString := '';
end;
WriteXY(Prompt + ': ', 1, Pred(Scr.CurrRows), Colors.PromptColor);
Edit(0);
ReadString := InputData^.ToString;
ESCPressed := GetQuit;
Done;
end; { with }
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.BlankColor);
end; { ReadString }
function GetLegalChar(Prompt : String; Legal : CharSet;
var ESCPressed : Boolean) : Char;
{ Read a chanracter from the input area, only reading certain ones }
var
Ch : Char;
begin
WriteXY(Prompt + ': ', 1, Pred(Scr.CurrRows), Colors.PromptColor);
Ch := GetKeyChar(Legal);
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.BlankColor);
GetLegalChar := Ch;
end; { GetLegalChar }
function GetYesNo(Prompt : String; var ESCPressed : Boolean) : Boolean;
{ Prints a "Yes/No" prompt, allowing the user to type Y or N to answer the
question }
var
Ch : Char;
begin
WriteXY(Prompt + ' (' + YesNo + ')?', 1, Pred(Scr.CurrRows),
Colors.PromptColor);
Ch := GetKeyChar(LegalYesNo);
ESCPressed := Ch = Chr(ESC);
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.BlankColor);
GetYesNo := Ch = 'Y';
end; { GetYesNo }
function GetNumber(Prompt : String; Low, High : Longint;
var Result : Boolean) : Longint;
{ Prompts for a numeric value within a certain range }
var
I : InputField;
S : String;
Error : Integer;
L : Longint;
begin
with I do
begin
if not Init(Length(Prompt) + 3, 0, -1,
Max(Length(NumToString(Low)),
Length(NumToString(High))), NotUpper) then
begin
Result := False;
GetNumber := 0;
Exit;
end;
WriteXY(Prompt + ': ', 1, Pred(Scr.CurrRows), Colors.PromptColor);
repeat
Edit(0);
S := InputData^.ToString;
if (not GetQuit) and (S <> '') then
begin
Val(S, L, Error);
Result := (Error = 0) and (L >= Low) and (L <= High);
if not Result then
Scr.PrintError(ErrNumberError1 + NumToString(Low) +
ErrNumberError2 + NumToString(High));
end
else begin
Result := False;
L := 0;
end;
until Result or (S = '');
Done;
end; { with }
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.BlankColor);
GetNumber := L;
end; { GetNumber }
end.


BIN
Borland Turbo Pascal v55/TCINPUT.TPU Normal file
View File

Binary file not shown.

243
Borland Turbo Pascal v55/TCLSTR.PAS Normal file
View File

@ -0,0 +1,243 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit TCLStr;
{ Turbo Pascal 5.5 object-oriented example long string routines.
This unit is used by TCALC.PAS.
See TCALC.DOC for an more information about this example.
}
{$S-}
interface
uses Objects, TCUtil;
const
MaxLStringLength = 65521; { The maximum amount that can be allocated
to a pointer }
type
LStringRange = 0..MaxLStringLength;
LStringData = array [1..MaxLStringLength] of Char;
LStringDataPtr = ^LStringData;
LStringPtr = ^LString;
LString = object
Len : LStringRange; { Current length }
MaxLen : LStringRange; { Length that has been allocated. This is
always allocated in blocks of 16 bytes so
that the long string's data doesn't have to
be reallocated every time the long string
grows }
Data : LStringDataPtr;
constructor Init;
destructor Done;
function SetValue(NewLen : LStringRange; NewData : Pointer) : Boolean;
function FromString(S : String) : Boolean;
function ToString : String;
function Length : LStringRange;
function Copy(Start, Amt : LStringRange) : String;
function Insert(S : String; Start : LStringRange) : Boolean;
procedure Delete(Start, Amt : LStringRange);
function Append(S : String) : Boolean;
procedure Change(Ch : Char; Start : LStringRange);
function Assign(LS : LString) : Boolean;
function FromStream(var S : DosStream) : Boolean;
procedure ToStream(var S : DosStream);
end;
implementation
constructor LString.Init;
{ Initializes the long string. }
begin
Len := 0;
MaxLen := 0;
Data := nil;
end; { LString.Init }
destructor LString.Done;
{ Frees memory used by the long string. }
begin
if Data <> nil then
FreeMem(Data, MaxLen);
end; { LString.Done }
function LString.SetValue(NewLen : LStringRange;
NewData : Pointer) : Boolean;
{ Copies an area of memory to the long string }
var
Size : Word;
NData : Pointer;
begin
Size := (NewLen + 15) shr 4 shl 4; { Calculate the new size }
if NewLen > MaxLen then { Allocate new data area if the long string }
begin { needs to grow }
GetMem(NData, Size);
if NData = nil then { The allocation failed. Return False }
begin
SetValue := False;
Exit;
end;
if Data <> nil then { If there was any data in the long string, }
begin { copy it to the new data area }
Move(Data^, NData^, Len);
FreeMem(Data, MaxLen); { Free the memory used by the long string }
end; { before it was reallocated }
Data := NData; { Set Data and MaxLen to their new values }
MaxLen := Size;
end;
Move(NewData^, Data^, NewLen); { Copy the new data to the long string }
Len := NewLen; { Set the length }
SetValue := True; { Successful - Return True }
end; { LString.SetValue }
function LString.FromString(S : String) : Boolean;
{ Converts a string into a long string }
begin
if not SetValue(System.Length(S), @S[1]) then
begin { Set the long string to be a null }
FromString := SetValue(0, nil); { string if it could not be expanded }
FromString := False; { Return False }
end
else
FromString := True; { Successful. Return True }
end; { LString.FromString }
function LString.ToString : String;
{ Converts a long string into a string }
var
S : String;
NewLen : Byte;
begin
NewLen := Min(255, Length); { The maximum length of a string is 255 }
S[0] := Chr(NewLen); { Set the length of the new string }
Move(Data^, S[1], NewLen); { Copy the data }
ToString := S; { Return the new string }
end; { LString.ToString }
function LString.Length : LStringRange;
{ Returns the current length of a long string }
begin
Length := Len;
end; { LString.Length }
function LString.Copy(Start, Amt : LStringRange) : String;
{ Copies part of a long string into a string }
var
S : String;
begin
if Start > Len then { Trying to copy past the end of the long }
Amt := 0 { string - return a null string }
else
Amt := Min(Amt, Succ(Len - Start)); { Calculate length of new string }
S[0] := Chr(Amt); { Set length of new string }
Move(Data^[Start], S[1], Amt); { Copy data into new string }
Copy := S; { Return new string }
end; { LString.Copy }
function LString.Insert(S : String; Start : LStringRange) : Boolean;
{ Inserts a string into a long string }
var
OldLen : LStringRange;
Size : Word;
NData : Pointer;
begin
OldLen := Len;
Inc(Len, System.Length(S));
if Len > MaxLen then { Allocate new data area if the long }
begin { string needs to grow }
Size := (Len + 15) shr 4 shl 4; { Calculate the new size }
GetMem(NData, Size); { Allocate new data area }
if NData = nil then { The long string could not be expanded }
begin
Dec(Len, System.Length(S)); { Restore the old Len value }
Insert := False; { Return False }
Exit;
end;
if Data <> nil then { If there was data in the long string, }
begin { copy it to the new data area }
Move(Data^, NData^, OldLen);
FreeMem(Data, MaxLen); { Free the old data area }
end;
Data := NData; { Set new values for Data and MaxLen }
MaxLen := Size;
end;
if Start <= OldLen then { Move the part of the string after the insert to }
{ the right to make space for the new string }
Move(Data^[Start], Data^[Start + System.Length(S)], Succ(OldLen - Start));
Move(S[1], Data^[Start], System.Length(S)); { Insert the new string }
Insert := True; { Successful - return True }
end; { LString.Insert }
procedure LString.Delete(Start, Amt : LStringRange);
{ Deletes part of a long string }
begin
Amt := Min(Amt, Succ(Len - Start)); { No characters can be deleted past
the end of the long string }
if Start + Amt <= Len then { The delete is in the middle of the long
string - move the rest of the data to the
left }
Move(Data^[Start + Amt], Data^[Start], Succ(Len - Amt - Start));
Dec(Len, Amt); { Fix the length value }
end; { LString.Delete }
function LString.Append(S : String) : Boolean;
{ Appends a string to a long string }
begin
Append := Insert(S, Succ(Len)); { Insert the string at the end }
end; { LString.Append }
procedure LString.Change(Ch : Char; Start : LStringRange);
{ Change a particular character of a long string }
begin
Move(Ch, Data^[Start], 1);
end; { LString.Change }
function LString.Assign(LS : LString) : Boolean;
{ Copy one long string to another one }
begin
Assign := SetValue(LS.Length, LS.Data);
end; { LString.Assign }
function LString.FromStream(var S : DosStream) : Boolean;
{ Read a long string from a stream }
var
Counter, NewLen, Size : Word;
Dummy : Byte;
NData : Pointer;
begin
S.Read(NewLen, SizeOf(NewLen)); { Read the length }
Size := (NewLen + 15) shr 4 shl 4; { Calculate the new size }
if NewLen > MaxLen then { Allocate new data area if the long string }
begin { needs to grow }
GetMem(NData, Size);
if NData = nil then { The allocation failed. Return False }
begin
for Counter := 1 to NewLen do { Read the string in so that the file }
S.Read(Dummy, 1); { position is still correct }
FromStream := False;
Exit;
end;
if Data <> nil then { If there was any data in the long string, }
begin { copy it to the new data area }
Move(Data^, NData^, Len);
FreeMem(Data, MaxLen);
end;
Data := NData; { Set new values for Data and MaxLen }
MaxLen := Size;
end;
S.Read(Data^, NewLen); { Read the long string from the stream }
Len := NewLen;
FromStream := True; { Successful - return True }
end; { LString.FromStream }
procedure LString.ToStream(var S : DosStream);
{ Write a long string to a stream }
begin
S.Write(Len, SizeOf(Len)); { Write the length }
S.Write(Data^, Len); { Write the long string }
end; { LString.ToStream }
end.


BIN
Borland Turbo Pascal v55/TCLSTR.TPU Normal file
View File

Binary file not shown.

234
Borland Turbo Pascal v55/TCMENU.PAS Normal file
View File

@ -0,0 +1,234 @@
{ Copyright (c) 1989 by Borland International, Inc. }
unit TCMenu;
{ Turbo Pascal 5.5 object-oriented example command line menu system.
This unit is used by TCALC.PAS.
See TCALC.DOC for an more information about this example.
}
{$S-}
interface
uses Crt, TCUtil, TCScreen;
{ The menus in this unit are very simple. Each menu points to a parent (so
that ESC will take you back to the previous menu) and a list of items.
Each item is either a pointer to a procedure that will be executed when
you choose the item, or is a pointer to a new menu.
}
type
MenuItemPtr = ^MenuItem;
MenuPtr = ^Menu;
Menu = object
MenuString, CommandString : StringPtr;
MenuItems, LastItem : MenuItemPtr;
Parent : MenuPtr;
constructor Init(InitMenuString : String; InitParent : MenuPtr);
procedure AddItem(NewItem : MenuItemPtr);
function AddItemProc(NewProc : ProcPtr) : Boolean;
function AddItemMenu(NewMenu : MenuPtr) : Boolean;
procedure RunMenu;
destructor Done;
end;
MenuItem = object
Next : MenuItemPtr;
constructor Init;
procedure RunItem(var CurrMenu : MenuPtr); virtual;
end;
MenuItemProcPtr = ^MenuItemProc;
MenuItemProc = object(MenuItem)
Proc : ProcPtr;
constructor Init(InitProc : ProcPtr);
procedure RunItem(var CurrMenu : MenuPtr); virtual;
end;
MenuItemMenuPtr = ^MenuItemMenu;
MenuItemMenu = object(MenuItem)
NewMenu : MenuPtr;
constructor Init(InitMenu : MenuPtr);
procedure RunItem(var CurrMenu : MenuPtr); virtual;
end;
implementation
constructor Menu.Init(InitMenuString : String; InitParent : MenuPtr);
{ Initializes a new menu }
var
S : String;
Counter : Word;
begin
MenuItems := nil;
LastItem := nil;
GetMem(MenuString, Succ(Length(InitMenuString)));
if MenuString = nil then
Fail;
MenuString^ := InitMenuString;
S := '';
for Counter := 1 to Length(InitMenuString) do
begin
if (InitMenuString[Counter] in ['A'..'Z']) then
{ Build command string based on upper case letters in mwenu string }
S := S + InitMenuString[Counter];
end;
GetMem(CommandString, Succ(Length(S)));
if CommandString = nil then
begin
Done;
Fail;
end;
CommandString^ := S;
Parent := InitParent;
end; { Menu.Init }
destructor Menu.Done;
{ Removes a menu from memory }
begin
if MenuString <> nil then
FreeMem(MenuString, Succ(Length(MenuString^)));
if CommandString <> nil then
FreeMem(CommandString, Succ(Length(CommandString^)));
LastItem := MenuItems;
while LastItem <> nil do
begin
MenuItems := LastItem;
LastItem := LastItem^.Next;
Dispose(MenuItems);
end;
end; { Menu.Done }
procedure Menu.AddItem(NewItem : MenuItemPtr);
{ Adds a new item to a menu }
begin
if MenuItems = nil then
begin
MenuItems := NewItem;
LastItem := MenuItems;
end
else begin
LastItem^.Next := NewItem;
LastItem := LastItem^.Next;
end;
end; { Menu.AddItem }
function Menu.AddItemProc(NewProc : ProcPtr) : Boolean;
{ Adds a procedure item to a menu }
var
NewItem : MenuItemProcPtr;
begin
NewItem := New(MenuItemProcPtr, Init(NewProc));
if NewItem <> nil then
begin
AddItem(NewItem);
AddItemProc := True;
end
else
AddItemProc := False;
end; { Menu.AddItemProc }
function Menu.AddItemMenu(NewMenu : MenuPtr) : Boolean;
{ Adds a new menu item to a menu }
var
NewItem : MenuItemMenuPtr;
begin
NewItem := New(MenuItemMenuPtr, Init(NewMenu));
if NewItem <> nil then
begin
AddItem(NewItem);
AddItemMenu := True;
end
else
AddItemMenu := False;
end; { Menu.AddItemMenu }
procedure Menu.RunMenu;
{ Run a menu system }
var
Ch, Counter, P : Word;
CurrMenu : MenuPtr;
I : MenuItemPtr;
begin
CurrMenu := @Self;
repeat
with CurrMenu^ do
begin
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.MenuLoColor); { Print the menu }
for Counter := 1 to Length(MenuString^) do
begin
if MenuString^[Counter] in ['A'..'Z'] then
WriteColor(MenuString^[Counter], Colors.MenuHiColor)
else
WriteColor(MenuString^[Counter], Colors.MenuLoColor);
end;
repeat
Ch := GetKeyUpCase;
case Ch of
ESC : CurrMenu := Parent;
Ord(' ')..Ord('~') : begin
P := Pos(Chr(Lo(Ch)), CommandString^);
if P <> 0 then { A menu item has been chosen }
begin
I := MenuItems;
for Counter := 2 to P do
begin
if I <> nil then
I := I^.Next;
end;
if I <> nil then
begin
I^.RunItem(CurrMenu); { Run the procedure or switch menus }
Ch := ESC;
end;
end;
end;
end; { case }
until Ch = ESC;
end; { with }
until CurrMenu = nil;
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.MenuLoColor);
end; { Menu.RunMenu }
constructor MenuItem.Init;
{ Initializes a menu item }
begin
Next := nil;
end; { MenuItem.Init }
procedure MenuItem.RunItem(var CurrMenu : MenuPtr);
begin
Abstract('MenuItem.RunItem');
end; { MenuItem.RunItem }
constructor MenuItemProc.Init(InitProc : ProcPtr);
{ Initializes a procedure menu item }
begin
MenuItem.Init;
Proc := InitProc;
end; { MenuItemProc.Init }
procedure MenuItemProc.RunItem(var CurrMenu : MenuPtr);
{ Runs the procedure that a procedure menu item points to }
begin
ClrEOLXY(1, Pred(Scr.CurrRows), Colors.MenuLoColor);
if @Proc <> nil then
Proc;
CurrMenu := nil;
end; { MenuItemProc.RunItem }
constructor MenuItemMenu.Init(InitMenu : MenuPtr);
{ Initializes a new menu menu item }
begin
MenuItem.Init;
NewMenu := InitMenu;
end; { MenuItemMenu.Init }
procedure MenuItemMenu.RunItem(var CurrMenu : MenuPtr);
{ Changes CurrMenu so that the menu that the item points to becomes the new
current menu }
begin
CurrMenu := NewMenu;
end; { MenuItemMenu.RunItem }
end.


Some files were not shown because too many files have changed in this diff Show More