home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
30TURUTL
/
PASCAL.LIB
< prev
next >
Wrap
Text File
|
1985-02-16
|
13KB
|
451 lines
{Include File: PASCAL.LIB}
type string80 = string[80];
charset = set of char;
dateset = (century,year,month,day);
datetype = array[century..day] of char;
screencommand = (stop,goback,goforward);
fieldtype = (alpha,dollar,numeric,yesno);
screenprompt = record
x,y,
flen:integer;
ftype:fieldtype;
prompt:string[15]
end;
const cr = ^M; { Keyboard constants }
lf = ^J;
crlf = ^M^J;
bell = ^G;
bs = ^H;
esc = ^[;
null = ''; { Concatenation constants }
space = ' ';
digits:charset = ['.', '-', '0'..'9', 'e', 'E'];
alphaset:charset = [' '..'}']; { Printable characters }
sysdate:datetype = #19#84#01#15; (* { January 15, 1984 } *)
var xsavx: integer; {one-deep save area for stack pointer}
(*
This is the code for simulating an Exit with TURBO Pascal 1.0,
provided the A+ compiler option is on -- no recursion!
A) Declare a GLOBAL Variable, " VAR XSAVX: INTEGER; ", included
here in the Pascal lib. Procedure need not be FORWARD now.
B) Include this as the FIRST instruction in the Procedure you wish
to eventually exit from, to set up the stack save:
inline($21/0/0/ { LD HL,0000h ; MARK PROC }
$39/ { ADD HL,SP ; FOR EXIT }
$22/xsavx); { LD (xsavx),HL }
C) Include this instead of Exit(Procname) in the procedure which
actually invokes the exit, & make it the LAST code in block:
inline($2A/xsavx/ { LD HL,(xsavx) ; EXIT PROC }
$F9); { LD SP,HL ; !!! }
Turbo will manage stack details when triggered by block end.
David C. Oshel, 15 January 1984, 1219 Harding Ave., Ames, Iowa 50010
*)
{:: Max and Min Functions
::
}
function max(a,b:integer):integer;
begin
if a<=b then max:=b else max:=a
end; {max}
function min(a,b:integer):integer;
begin
if b<=a then min:=b else min:=a
end; {min}
{:: DrawBox Procedure
::
:: Just what it sez; you supply the top left (x1,y1) and
:: bottom right (x2,y2) coordinates, and it draws a box on the
:: screen using the characters you want to draw the top, bottom
:: and sides.
::
}
procedure drawbox(x1,y1,x2,y2:integer; top,side,bottom:char);
var i:integer;
begin
gotoxy(x1,y1);
for i:=x1 to x2 do write(top);
gotoxy(x1,y1+1);
for i:=y2 downto y1+1 do
begin
gotoxy(x2,i); write(side);
gotoxy(x1,i); write(side)
end;
gotoxy(x1,y2);
for i:=x1 to x2 do write(bottom)
end; {drawbox}
{:: GetLine Procedure
::
:: Set the VAR string parameter to user input, restricted to
:: a set of allowed characters, less than or equal to allowed length.
::
}
procedure getln(VAR s:string80; okset:charset; maxlen:integer);
var ch: char;
stemp: string80;
len: integer;
first,
last: boolean;
getset:charset;
function getchar(okset:charset):char;
var ok:boolean; ch:char;
begin
repeat
read(KBD,ch);
if eoln(KBD) then ch:=cr;
ok:=ch in okset;
if not ok
then write(CON,bell)
else if ch in alphaset then write(CON,ch)
until ok;
getchar:=ch
end; {getchar}
begin
stemp:=null;
ch:=space;
repeat
len:=length(stemp);
first:=len=0;
last:=len=maxlen;
if first then getset:=okset+[cr]
else if last then getset:=[cr,bs]
else getset:=okset+[cr,bs];
ch:=getchar(getset);
if ch=bs then
begin
write(bs,space,bs);
delete(stemp,len,1)
end
else if ch in okset-[cr] then stemp:=stemp+ch
until ch=cr;
s:=stemp
end; {getln}
{:: DATE Utilities
::
}
procedure bombline(VAR s:string80; select:charset);
var go: boolean;
begin
go:=true;
while (s<>null) and go do
begin
if s[1] in select then go:=false
else delete(s,1,1)
end
end; {bombline}
function ival(VAR s:string80):integer;
VAR go: boolean; n:integer;
begin
n:=0; go:=true;
while (s<>null) and go do
begin
if s[1] in ['0'..'9'] then
n:=( n*10 + ord(s[1])-ord('0') ) mod 3000
else go:=false;
delete(s,1,1)
end;
ival:=n
end; {ival}
function monthval(VAR s:string80):integer;
var z:string[3]; n:integer;
begin
if length(s)>=3 then
begin
z:=copy(s,1,3);
for n:=1 to 3 do z[n]:=upcase(z[n]);
if z='JAN' then n:=1
else if z='FEB' then n:=2
else if z='MAR' then n:=3
else if z='APR' then n:=4
else if z='MAY' then n:=5
else if z='JUN' then n:=6
else if z='JUL' then n:=7
else if z='AUG' then n:=8
else if z='SEP' then n:=9
else if z='OCT' then n:=10
else if z='NOV' then n:=11
else if z='DEC' then n:=12
else n:=0
end;
bombline(s,['0'..'9']);
if n=0 then monthval:=ival(s)
else monthval:=n
end; {monthval}
procedure dateval(VAR update:datetype; VAR s:string80);
var i: century..day;
x,y,z: array[century..day] of integer;
n: integer;
begin
for n:=1 to length(s) do s[n]:=upcase(s[n]);
y[century]:=ord(update[century]); z[century]:= 30;
y[year] :=ord(update[year]); z[year] :=100;
y[month] :=ord(update[month]); z[month] := 13;
y[day] :=ord(update[day]); z[day] := 32;
for i:=day downto year do
begin
n:=monthval(s);
x[i]:=n mod z[i]
end;
x[century]:=n div 100;
for i:=century to day do
begin
if x[i]=0 then x[i]:=y[i];
update[i]:=chr(x[i])
end
end; {dateval}
procedure monthstr(VAR s:string80; m:integer);
begin
case m of
1: s:='January';
2: s:='February';
3: s:='March';
4: s:='April';
5: s:='May';
6: s:='June';
7: s:='July';
8: s:='August';
9: s:='September';
10: s:='October';
11: s:='November';
12: s:='December'
else s:='???'
end
end; {monthstr}
procedure datestr(VAR s:string80; d:datetype; long:boolean);
var gimmick: char; scratch: string80;
begin
if long
then gimmick:=' '
else gimmick:='/';
str(ord(d[day]),scratch);
s:=scratch+gimmick;
if long
then monthstr(scratch,ord(d[month]))
else str(ord(d[month]),scratch);
s:=s+scratch+gimmick;
if long then begin
str(ord(d[century]),scratch);
s:=s+scratch
end;
str(ord(d[year]),scratch);
if length(scratch)=1 then insert('0',scratch,1);
s:=s+scratch
end; {datestr}
procedure putdate(d:datetype; long:boolean);
var temp:string80;
begin
datestr(temp,d,long); write(temp)
end; {putdate}
procedure setdate;
var prompt:string80;
begin
writeln;
write('Today is '); putdate(sysdate,true); writeln;
write('New date? ');
getln(prompt,alphaset,20); writeln;
dateval(sysdate,prompt);
write('The date is '); putdate(sysdate,true);
writeln
end; {setdate}
{:: GetField Function
:: Parameters: Screen prompt record, string80 to be updated.
:: Returns: Screen commands STOP, GOBACK or GOFORWARD.
::
:: This function moves the cursor into a protected screen field
:: and waits for user input. If user types <RETURN> the previous
:: value of the field is accepted as the new value. Otherwise,
:: the field is cleared and a new value must be typed in. Fields
:: are validated for the types Alpha, Dollar, Numeric and YesNo. The
:: YesNo type assumes NO if OLDS is null on entry, otherwise no
:: assumptions are made. The values are set by side effects.
::
:: If the user types <BACKSPACE> or <ESCAPE>, the previous value is
:: unchanged and the function returns screen commands GOBACK or STOP.
:: Otherwise, the function returns GOFORWARD. ^Q is defined as BS,
:: and ^Z is defined as CR, for additional screen control.
}
function getfld(VAR field:screenprompt; VAR olds:string80):screencommand;
var i, code: integer; signchar,ch: char; r:real; rstr: string[12];
procedure getln(VAR s:string80; okset:charset; maxlen:integer);
var ch: char;
stemp: string80;
len: integer;
first,
last: boolean;
getset:charset;
function getchar(okset:charset):char;
var ok:boolean; ch:char;
begin
repeat
read(KBD,ch);
if eoln(KBD) then ch:=cr;
ok:=ch in okset;
if not ok
then write(CON,bell)
else if ch in alphaset then write(CON,ch)
until ok;
getchar:=ch
end; {getchar}
begin
stemp:=s; {this line is why getln is duplicated}
repeat
len:=length(stemp);
first:=len=0;
last:=len=maxlen;
if first then getset:=okset+[cr]
else if last then getset:=[cr,bs]
else getset:=okset+[cr,bs];
ch:=getchar(getset);
if ch=bs then
begin
write(bs,'.',bs); {and this one!}
delete(stemp,len,1)
end
else if ch in okset-[cr] then stemp:=stemp+ch
until ch=cr;
s:=stemp
end; {getln}
begin
with field do
begin
if (ftype=yesno) then flen:=1
else if (ftype=dollar) then flen:=min(flen,12)
else if (ftype=numeric) then flen:=min(flen,5)
else flen:=min(flen,80);
{display old values}
gotoxy(x,y);
if ftype=dollar
then write(prompt,space,olds:flen)
else begin
write(prompt,space,olds);
for i:=length(olds)+1 to flen do write(space)
end;
gotoxy(x+length(prompt)+1,y);
{get user input; either screen command or first char of new input}
repeat until keypressed;
read(kbd,ch);
{screen command character?}
if eoln(kbd) then
begin
if olds=null then
begin
case ftype of
alpha: ;
dollar: begin olds:='$0.00'; write(olds:flen) end;
numeric: begin olds:='0'; write(olds:flen) end;
yesno: begin olds:='N'; write(olds) end;
end {case}
end;
getfld:=goforward
end
else if (ch=bs) or (ch=^Q) then getfld:=goback
else if ch=esc then getfld:=stop
else {not a screen command, this is new input}
begin
olds:=null;
case ftype of
alpha: if ch in alphaset then olds:=null+ch;
dollar: if ch in digits then olds:=null+ch;
numeric: if ch in ['0'..'9'] then olds:=null+ch;
yesno: if ch in ['y','Y'] then olds:='Y'
else olds:='N'
end; {case}
gotoxy(x+length(prompt)+1,y);
write(olds);
for i:=length(olds)+1 to flen do write('.');
gotoxy(x+length(prompt)+length(olds)+1,y);
case ftype of
alpha: getln(olds,alphaset,flen);
dollar: getln(olds,digits,flen);
numeric: getln(olds,['0'..'9'],flen);
yesno: begin
getln(olds,['y','n','Y','N'],flen);
olds:=upcase(olds)
end
end; {case}
{validate entry}
gotoxy(x+length(prompt)+1,y);
if ftype=dollar then
begin
val(olds,r,code);
if code=0 then
begin
if r<0 then signchar:='-' else signchar:=' ';
r:=abs(r);
str(r:12:2,olds);
olds:=signchar+'$'+olds;
while pos(space,olds)>0 do delete(olds,pos(space,olds),1);
if length(olds) > flen then olds:='$LEN'
end
else {did not evaluate to a number}
begin
olds:='$EVA'
end;
write(olds:flen)
end {field type was dollar}
else begin {field type was alpha, simple numeric or yesno}
write(olds);
for i:=length(olds)+1 to flen do write(space)
end;
getfld:=goforward
end {new input, first character was not a screen command}
end {with field variable}
end; {getfld}
{End of Include File: PASCAL.LIB}