(***************************************************************************)
(* *)
(* Erste von drei Dateien des EUMEL-BASIC-Systems *)
(* *)
(* Autor: Heiko Indenbirken *)
(* Überarbeitet von: Rudolf Ruland und Michael Overdick *)
(* *)
(* Stand: 27.10.1987 *)
(* *)
(***************************************************************************)
PACKET basic std DEFINES EQU, UEQ, (* Autor: Heiko Indenbirken *)
LES, LEQ, (* Stand: 23.10.1987/rr/mo *)
GRE, GEQ,
EQV, IMP,
^, swap,
val, asc, cdbl, chr,
cint, cvi, cvd, fre,
hex, inchars,
instr, ent, left,
mid, mki, mkd,
oct, right,
rnd, init rnd,
space, string,
l set, r set,
int not, real not,
/, DIV, real mod,
time, timer,
arctan, cos, sin, tan,
exp, ln, floor,
sqrt:
INT CONST true := -1,
false := 0;
LET real overflow = 6;
(*BASIC-Integervergleiche *)
INT OP EQU (INT CONST a, b):
IF a=b
THEN true
ELSE false FI
END OP EQU;
INT OP UEQ (INT CONST a, b):
IF a=b
THEN false
ELSE true FI
END OP UEQ;
INT OP LES (INT CONST a, b):
IF a<b
THEN true
ELSE false FI
END OP LES;
INT OP LEQ (INT CONST a, b):
IF a<=b
THEN true
ELSE false FI
END OP LEQ;
INT OP GRE (INT CONST a, b):
IF a>b
THEN true
ELSE false FI
END OP GRE;
INT OP GEQ (INT CONST a, b):
IF a>=b
THEN true
ELSE false FI
END OP GEQ;
(*BASIC-Realvergleiche *)
INT OP EQU (REAL CONST a, b):
IF a=b
THEN true
ELSE false FI
END OP EQU;
INT OP UEQ (REAL CONST a, b):
IF a=b
THEN false
ELSE true FI
END OP UEQ;
INT OP LES (REAL CONST a, b):
IF a<b
THEN true
ELSE false FI
END OP LES;
INT OP LEQ (REAL CONST a, b):
IF a<=b
THEN true
ELSE false FI
END OP LEQ;
INT OP GRE (REAL CONST a, b):
IF a>b
THEN true
ELSE false FI
END OP GRE;
INT OP GEQ (REAL CONST a, b):
IF a>=b
THEN true
ELSE false FI
END OP GEQ;
(*BASIC-Tesxtvergleiche *)
INT OP EQU (TEXT CONST a, b):
IF a=b
THEN true
ELSE false FI
END OP EQU;
INT OP UEQ (TEXT CONST a, b):
IF a=b
THEN false
ELSE true FI
END OP UEQ;
INT OP LES (TEXT CONST a, b):
IF a<b
THEN true
ELSE false FI
END OP LES;
INT OP LEQ (TEXT CONST a, b):
IF a<=b
THEN true
ELSE false FI
END OP LEQ;
INT OP GRE (TEXT CONST a, b):
IF a>b
THEN true
ELSE false FI
END OP GRE;
INT OP GEQ (TEXT CONST a, b):
IF a>=b
THEN true
ELSE false FI
END OP GEQ;
(*BASIC INTEGER / BOOL Operatoren *)
REAL PROC real not (REAL CONST a): (* mo *)
real (int (a) XOR -1)
END PROC real not;
INT PROC int not (INT CONST a): (* mo *)
a XOR -1
END PROC int not;
INT OP EQV (INT CONST l, r):
int not (l XOR r)
END OP EQV;
INT OP IMP (INT CONST l, r):
(l EQV r) OR r
END OP IMP;
LET smallest significant = 5.0e-12;
REAL OP ^ (REAL CONST x, y): (* F22/rr *)
IF x > 0.0
THEN x ** y
ELIF x = 0.0
THEN IF y > 0.0
THEN 0.0
ELIF y = 0.0
THEN 1.0
ELSE errorstop (real overflow, "");
max real
FI
ELSE REAL VAR floor y := floor (y + round value);
IF (abs (y - floor y) > smallest significant)
COR (floor y = 0.0 AND y <> 0.0)
THEN errorstop (1005, "bei " + text (x) +
" ^ " + text (y, 19) +
" : neg. Basis, gebr. Exponent");
0.0
ELIF (floor y MOD 2.0) = 0.0
THEN (-x) ** floor y
ELSE - ( (-x) ** floor y )
FI
FI .
round value : IF y >= 0.0 THEN 0.5 ELSE -0.5 FI .
END OP ^;
REAL OP ^ (INT CONST x, y):
real (x) ** y
END OP ^;
REAL OP / (INT CONST l, r): (* mo *)
real (l) / real (r)
END OP /;
INT OP DIV (REAL CONST l, r): (* mo *)
cint (l) DIV cint (r)
END OP DIV;
REAL PROC real mod (REAL CONST l, r): (* mo *)
round (l, 0) MOD round (r, 0)
END PROC real mod;
(* Basic Arithmetik *)
REAL VAR r swap;
PROC swap (REAL VAR left, right):
r swap := left;
left := right;
right := r swap
END PROC swap;
INT VAR i swap;
PROC swap (INT VAR left, right):
i swap := left;
left := right;
right := i swap
END PROC swap;
TEXT VAR t swap;
PROC swap (TEXT VAR left, right):
t swap := left;
left := right;
right := t swap
END PROC swap;
(*Internkonvertierungen *)
INT PROC cvi (TEXT CONST v):
v ISUB 1
END PROC cvi;
REAL PROC cvd (TEXT CONST v):
v RSUB 1
END PROC cvd;
TEXT VAR i text :: 2*""0"", r text :: 8*""0"";
TEXT PROC mki (REAL CONST x):
mki (cint (x))
END PROC mki;
TEXT PROC mki (INT CONST i):
replace (i text, 1, i);
i text
END PROC mki;
TEXT PROC mkd (INT CONST i):
mkd (real (i))
END PROC mkd;
TEXT PROC mkd (REAL CONST r):
replace (r text, 1, r);
r text
END PROC mkd;
(*Textoperationen *)
PROC l set (TEXT VAR left, TEXT CONST right):
replace (left, 1, right)
END PROC l set;
PROC r set (TEXT VAR left, TEXT CONST right):
replace (left, length (left)-length (right)+1, right)
END PROC r set;
TEXT PROC left (TEXT CONST string, REAL CONST no):
left (string, cint (no))
END PROC left;
TEXT PROC left (TEXT CONST string, INT CONST no):
subtext (string, 1, no)
END PROC left;
TEXT PROC right (TEXT CONST string, REAL CONST no):
right (string, cint (no))
END PROC right;
TEXT PROC right (TEXT CONST string, INT CONST no):
subtext (string, length (string)-no+1)
END PROC right;
TEXT PROC mid (TEXT CONST source, REAL CONST from):
mid (source, cint (from))
END PROC mid;
TEXT PROC mid (TEXT CONST source, INT CONST from):
subtext (source, from)
END PROC mid;
TEXT PROC mid (TEXT CONST source, REAL CONST from, length):
mid (source, cint (from), cint (length))
END PROC mid;
TEXT PROC mid (TEXT CONST source, INT CONST from, length):
subtext (source, from, from+length-1)
END PROC mid;
TEXT PROC string (REAL CONST x, y):
string (cint (x), cint (y))
END PROC string;
TEXT PROC string (INT CONST x, REAL CONST y):
string (x, cint (y))
END PROC string;
TEXT PROC string (REAL CONST x, INT CONST y):
string (cint (x), y)
END PROC string;
TEXT PROC string (INT CONST i, j):
i * code (j)
END PROC string;
TEXT PROC string (REAL CONST i, TEXT CONST x):
string (cint (i), x)
END PROC string;
TEXT PROC string (INT CONST i, TEXT CONST x):
i * (x SUB 1)
END PROC string;
(*Konvertierungen *)
REAL PROC val (TEXT CONST text) : (* F18/rr *)
TEXT VAR buffer := text;
change (buffer, "d", "e");
change (buffer, "D", "e");
change (buffer, "E", "e");
real (buffer)
END PROC val;
REAL PROC asc (TEXT CONST text):
real (code (text SUB 1))
END PROC asc;
TEXT PROC chr (INT CONST n):
code (n)
END PROC chr;
TEXT PROC chr (REAL CONST n):
code (cint (n))
END PROC chr;
TEXT PROC hex (REAL CONST x):
hex (cint (x))
END PROC hex;
TEXT PROC hex (INT CONST x):
TEXT VAR value :: "12";
replace (value, 1, x);
high byte + low byte .
low byte:
hexdigit (code (value SUB 1) DIV 16) + hexdigit (code (value SUB 1) MOD 16) .
high byte:
IF (value SUB 2) = ""0""
THEN ""
ELSE hexdigit (code (value SUB 2) DIV 16) +
hexdigit (code (value SUB 2) MOD 16)
FI .
END PROC hex;
TEXT PROC oct (REAL CONST x):
oct (cint (x))
END PROC oct;
TEXT PROC oct (INT CONST x):
INT VAR number :: x AND maxint;
generate oct number;
IF x < 0
THEN "1" + oct number
ELSE subtext (oct number, pos (oct number, "1", "7", 1))
FI.
generate oct number:
TEXT VAR oct number :: "";
INT VAR digit;
FOR digit FROM 1 UPTO 5 REP
oct number := hexdigit (number MOD 8) + oct number;
number := number DIV 8
PER.
END PROC oct;
TEXT PROC hexdigit (INT CONST digit):
IF 0 <= digit AND digit <= 9
THEN code (digit + 48)
ELIF 10 <= digit AND digit <= 15
THEN code (digit + 55)
ELSE errorstop (1051, "Hexziffer außerhalb des gültigen Bereichs"); "" FI
END PROC hexdigit;
TEXT PROC inchars (REAL CONST n):
inchars (cint (n))
END PROC inchars;
TEXT PROC inchars (INT CONST n):
TEXT VAR buffer :: "", char;
INT VAR i;
FOR i FROM 1 UPTO n
REP inchar (char);
buffer CAT char
PER;
buffer
END PROC inchars;
(*Mathematische Prozeduren *)
REAL PROC ent (INT CONST r):
real (r)
END PROC ent;
REAL PROC ent (REAL CONST r):
IF r >= 0.0 OR frac (r) = 0.0
THEN floor (r)
ELSE floor (r-1.0) FI
END PROC ent;
REAL PROC cdbl (INT CONST r):
real (r)
END PROC cdbl;
REAL PROC cdbl (REAL CONST r):
r
END PROC cdbl;
INT PROC cint (INT CONST r):
r
END PROC cint;
INT PROC cint (REAL CONST r):
IF r >= 0.0
THEN int (r+0.5)
ELSE int (r-0.5) FI
END PROC cint;
REAL VAR last rnd :: rnd (1.0);
REAL PROC rnd (INT CONST x):
rnd (real (x))
END PROC rnd;
REAL PROC rnd (REAL CONST x):
IF x > 0.0
THEN last rnd := random;
last rnd
ELIF x = 0.0
THEN last rnd
ELSE init rnd (x);
last rnd := random;
last rnd
FI
END PROC rnd;
REAL PROC rnd:
rnd (1.0)
END PROC rnd;
PROC init rnd (REAL CONST init value) :
REAL VAR init := init value;
IF init <= -1.0 OR 1.0 <= init
THEN set exp (- decimal exponent (init) - 1, init) FI;
initialize random (init)
END PROC init rnd;
REAL PROC fre (TEXT CONST dummy):
INT VAR f, u;
collect heap garbage;
storage (f, u);
real (f - u) * 1024.0
END PROC fre;
REAL PROC fre (REAL CONST dummy):
fre ("")
END PROC fre;
REAL PROC fre (INT CONST dummy):
fre ("")
END PROC fre;
(*Inputroutinenen *)
INT PROC instr (TEXT CONST source, pattern):
pos (source, pattern)
END PROC instr;
INT PROC instr (REAL CONST from, TEXT CONST source, pattern):
instr (cint (from), source, pattern)
END PROC instr;
INT PROC instr (INT CONST from, TEXT CONST source, pattern):
pos (source, pattern, from)
END PROC instr;
TEXT PROC space (REAL CONST len):
space (cint (len))
END PROC space;
TEXT PROC space (INT CONST len):
len * " "
END PROC space;
TEXT PROC time: (* mo *)
subtext (time (clock (1) MOD day), 1, 8) (* hh:mm:ss *)
END PROC time;
REAL PROC timer:
clock (0)
END PROC timer;
REAL PROC arctan (INT CONST x):
arctan (real (x))
END PROC arctan;
REAL PROC cos (INT CONST x):
cos (real (x))
END PROC cos;
REAL PROC sin (INT CONST x):
sin (real (x))
END PROC sin;
REAL PROC tan (INT CONST x):
tan (real (x))
END PROC tan;
REAL PROC exp (INT CONST x):
exp (real (x))
END PROC exp;
REAL PROC ln (INT CONST x):
ln (real (x))
END PROC ln;
REAL PROC floor (INT CONST x):
real (x)
END PROC floor;
REAL PROC sqrt (INT CONST x):
sqrt (real (x))
END PROC sqrt;
END PACKET basic std;
PACKET basic using DEFINES using, (* Autor: Heiko Indenbirken *)
clear using, (* Stand: 05.08.1987/rr/mo *)
basic text:
LET exclamation point = "!",
backslash = "\",
comercial and = "&",
numbersign = "#",
plus = "+",
minus = "-",
asterisk dollar = "**$",
asterisk = "**",
dollarsign = "$$",
comma = ",",
point = ".",
caret = "^^^^",
underscore = "_",
blank = " ",
nil = "",
number format chars = "#+-*$.^",
format chars = "!\&#+-$*.";
TEXT VAR result, using format :: "", pre format :: "";
INT VAR using pos :: 0;
BOOL VAR image used :: FALSE;
PROC using (TEXT CONST format):
using format := format;
using pos := 0;
result := "";
image used := TRUE
END PROC using;
PROC clear using:
using format := "";
image used := FALSE
END PROC clear using;
TEXT PROC next format:
pre format := "";
IF using pos = 0
THEN ""
ELSE search rest of format FI .
search rest of format:
WHILE using pos <= length (using format)
REP IF at underscore
THEN using pos INCR 1;
pre format CAT akt char
ELIF at format char
THEN LEAVE next format WITH pre format
ELSE pre format CAT akt char FI;
using pos INCR 1
PER;
using pos := 0;
pre format .
at underscore:
akt char = underscore .
at format char:
pos (format chars, akt char) > 0 CAND
evtl double asterisk CAND
evtl point with numbersign .
evtl double asterisk:
akt char <> asterisk COR next char = asterisk .
evtl point with numbersign:
akt char <> point COR next char = numbersign .
akt char: using format SUB using pos .
next char: using format SUB using pos+1 .
END PROC next format;
PROC init (TEXT VAR l result):
IF using pos = 0
THEN using pos := 1;
l result := next format;
IF using pos = 0
THEN errorstop (1005, "USING: kein Format gefunden") FI
ELSE l result := "" FI
END PROC init;
TEXT PROC basic text (TEXT CONST string):
IF image used
THEN using text
ELSE string FI .
using text:
init (result);
result CAT format string;
using pos INCR 1;
result CAT next format;
result .
format string:
IF akt char = exclamation point
THEN string SUB 1
ELIF akt char = backslash
THEN given length string
ELIF akt char = comercial and
THEN string
ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI .
given length string:
INT VAR len :: 2;
FOR using pos FROM using pos+1 UPTO length (using format)
REP IF akt char = "\"
THEN LEAVE given length string WITH text (string, len) FI;
len INCR 1
UNTIL akt char <> " "PER;
errorstop (1005, "USING-Format fehlerhaft: " + using format);
"" .
akt char: using format SUB using pos
END PROC basic text;
TEXT PROC basic text (INT CONST number):
IF image used
THEN basic text (real (number))
ELSE sign + text (number) FI .
sign:
IF number >= 0
THEN " "
ELSE "" FI .
END PROC basic text;
TEXT PROC basic text (REAL CONST number):
IF image used
THEN using text
ELSE normal text FI .
normal text:
(* Bei Real Zahlen werden maximal 7 signifikante Stellen ausgegeben, *)
(* führende und nachfolgende Nullen werden unterdrückt, *)
(* der Dezimalpunkt wird im Normalformat unterdrückt *)
calculate sign;
REAL VAR mantissa := round (abs (number), 6-decimal exponent (number));
INT CONST exp :: decimal exponent (mantissa);
IF mantissa = 0.0
THEN result := " 0"
ELIF exp > 6 OR exp < -7 OR (exp < 0 AND more than 7 signifikant digits)
THEN scientific notation
ELIF exp < 0
THEN short negative notation
ELSE short positive notation FI;
result .
more than 7 signifikant digits:
REAL VAR signifikant := mantissa;
set exp (7+exp, signifikant);
frac (signifikant) <> 0.0 .
calculate sign:
IF number >= 0.0
THEN result := " "
ELSE result := "-" FI .
scientific notation:
set exp (0, mantissa);
result CAT non zero (text (mantissa, 8, 6));
IF exp < 0
THEN result CAT "E-"
ELSE result CAT "E+" FI;
IF abs (exp) > 9
THEN result CAT text (abs (exp))
ELSE result CAT "0";
result CAT text (abs (exp))
FI .
short positive notation:
result CAT non zero (text (mantissa, 8, 6-exp));
IF (result SUB LENGTH result) = "."
THEN delete char (result, LENGTH result) FI .
short negative notation:
result CAT non zero (subtext (text (abs (mantissa), 9, 7), 2)).(* F13/rr *)
using text:
init (result);
result CAT format number (subformat, number);
result CAT next format;
result .
subformat:
INT VAR from :: using pos, to :: last format char;
subtext (using format, from, to) .
last format char:
FOR using pos FROM using pos+1 UPTO length (using format)
REP IF non format char
THEN LEAVE last format char WITH using pos-1 FI
PER;
using pos := 0;
length (using format) .
non format char:
IF (using format SUB using pos) = comma
THEN (using format SUB (using pos+1)) <> point
ELSE pos (numberformat chars, using format SUB using pos) = 0 FI .
END PROC basic text;
TEXT PROC non zero (TEXT CONST text):
INT VAR i;
FOR i FROM length (text) DOWNTO 2
REP UNTIL (text SUB i) <> "0" PER;
subtext (text, 1, i)
END PROC non zero;
TEXT PROC format number (TEXT CONST format, REAL CONST number):
IF no digit char
THEN errorstop (1005, "USING-Format fehlerhaft: " + using format); ""
ELIF exponent found
THEN exponent format
ELSE normal format FI .
no digit char:
pos (format, numbersign) = 0 AND
pos (format, asterisk) = 0 AND
pos (format, dollarsign) = 0 .
exponent found:
INT CONST exponent pos := pos (format, caret);
exponent pos > 0 .
exponent format:
IF leading plus
THEN plus or minus + exponent field (subtext (format, 2), number, exponent pos-1)
ELIF trailing plus
THEN exponent field (format, number, exponent pos) + plus or minus
ELIF trailing minus
THEN exponent field (format, number, exponent pos) + nil or minus
ELSE blank or minus + exponent field (subtext (format, 2), number, exponent pos-1) FI .
normal format:
IF leading numbersign
THEN number field (format, number, "", " ")
ELIF leading point
THEN number field (format, number, "", " ")
ELIF leading plus
THEN number field (format, abs (number), plus or minus, " ")
ELIF leading asterisk dollar
THEN number field (format, number, "$", "*")
ELIF leading asterisk
THEN number field (format, number, "", "*")
ELIF leading dollarsign
THEN number field (format, number, "$", " ")
ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI .
leading numbersign: (format SUB 1) = numbersign .
leading point: (format SUB 1) = point .
leading plus: (format SUB 1) = plus .
leading asterisk dollar: subtext (format, 1, 3) = asterisk dollar .
leading asterisk: subtext (format, 1, 2) = asterisk .
leading dollarsign: subtext (format, 1, 2) = dollarsign .
trailing minus: (format SUB LENGTH format) = minus .
trailing plus: (format SUB LENGTH format) = plus .
plus or minus: IF number < 0.0 THEN minus ELSE plus FI .
nil or minus: IF number < 0.0 THEN minus ELSE nil FI .
blank or minus: IF number < 0.0 THEN minus ELSE blank FI .
END PROC format number;
TEXT PROC exponent field (TEXT CONST format, REAL CONST value, INT CONST exponent pos):
REAL VAR number := abs (value);
INT CONST point pos := pos (format, point);
calc leading and trailing;
INT CONST new exponent :: decimal exponent (value) - leading + 1;
IF abs (new exponent) >= 100
THEN "%" + mantissa + "E" + null text (new exponent, 4)
ELSE mantissa + exponent
FI.
calc leading and trailing:
INT VAR leading, trailing;
IF point pos = 0
THEN leading := exponent pos-1;
trailing := 0
ELSE leading := point pos-1;
trailing := exponent pos-point pos-1
FI .
mantissa:
set exp (leading - 1, number);
IF point pos = 0
THEN subtext (text (number, leading+1, 0), 1, leading)
ELSE subtext (text (number, leading+trailing+2, trailing), 2) FI .
exponent:
"E" + null text (new exponent, 3) .
END PROC exponent field;
TEXT PROC number field (TEXT CONST format, REAL CONST value,
TEXT CONST pretext, lead char):
INT CONST point pos :: pos (format, point);
calc fraction;
calc digits;
calc commata if necessary;
fill with lead chars and sign .
calc fraction:
INT VAR fraction :: 0, i;
FOR i FROM point pos+1 UPTO length (format)
WHILE (format SUB i) = numbersign
REP fraction INCR 1 PER .
calc digits:
TEXT VAR valuetext;
IF point pos = 0
THEN valuetext := digits (abs (value), 0, TRUE);
delete char (valuetext, length (valuetext))
ELSE valuetext := digits (abs (value), fraction, point pos <> 1) FI .
calc commata if necessary:
IF comma before point
THEN insert commata FI .
comma before point:
point pos > 0 CAND (format SUB point pos-1) = comma .
insert commata:
i := pos (valuetext, point)-3;
WHILE i > 1 CAND (valuetext SUB i) <> " "
REP insert char (valuetext, ",", i);
i DECR 3
PER .
fill with lead chars and sign:
IF trailing minus
THEN fillby (pretext + valuetext, length (format)-1, lead char) + nil or minus
ELIF trailing plus
THEN fillby (pretext + valuetext, length (format)-1, lead char) + plus or minus
ELIF value < 0.0
THEN fillby (pretext + minus + valuetext, length (format), lead char)
ELSE fillby (pretext + valuetext, length (format), lead char) FI .
plus or minus: IF value < 0.0 THEN minus ELSE plus FI .
nil or minus: IF value < 0.0 THEN minus ELSE nil FI .
trailing minus: (format SUB LENGTH format) = minus .
trailing plus: (format SUB LENGTH format) = plus .
END PROC numberfield;
TEXT PROC null text (INT CONST n, digits):
TEXT VAR l result := text (abs (n), digits);
IF n < 0
THEN replace (l result, 1, "-")
ELSE replace (l result, 1, "+") FI;
change all (l result, " ", "0");
l result .
END PROC null text;
TEXT PROC fillby (TEXT CONST source, INT CONST format, TEXT CONST with):
IF differenz >= 0
THEN differenz * with + source
ELSE "%" + source FI .
differenz: format - length (source) .
END PROC fillby;
TEXT PROC digits (REAL CONST value, INT CONST frac, BOOL CONST null):
IF decimal exponent (value) < 0
THEN TEXT VAR l result := text (value, frac+2, frac);
IF null AND first char <> "0"
THEN replace (l result, 1, "0");
l result
ELIF (NOT null AND first char = "0") OR first char = " "
THEN subtext (l result, 2)
ELSE l result FI
ELSE text (value, decimal exponent (value)+frac+2, frac) FI .
first char:
(l result SUB 1) .
END PROC digits;
TEXT PROC right (TEXT CONST msg, INT CONST len):
IF length (msg) >= len
THEN subtext (msg, 1, len)
ELSE (len - length (msg)) * " " + msg FI
END PROC right;
END PACKET basic using;
PACKET basic output (* Autor: R. Ruland *)
(* Stand: 28.08.1987/rr/mo *)
DEFINES basic page,
width,
init output,
basic out,
basic write,
tab,
next zone,
next line,
next page,
cursor x pos,
pos,
csrlin,
l pos,
switch to printout file,
switch back to old sysout state:
LET zone width = 16; (* sd.ddddddEsdddb (s = sign, d = digit, b = blank) *)
LET printfile name = "BASIC LPRINT OUTPUT";
INT VAR screen width, x cursor, y cursor, line no;
BOOL VAR paging := FALSE, first time,
in lprint; (* mo *)
TEXT VAR buffer, output line, last sysout file, old sysout, char;
PROC basic page (BOOL CONST status):
paging := status
END PROC basic page;
BOOL PROC basic page: paging END PROC basic page;
PROC width (INT CONST max):
IF max < 0
THEN errorstop (1005, "WIDTH: negatives Angabe: " + text (max))
ELIF max = 0
THEN screen width := 1
ELSE screen width := max
FI;
last sysout file := "";
END PROC width;
INT PROC width : screen width END PROC width;
PROC init output:
clear using;
width (max (1, x size));
line no := 1;
output line := "";
first time := TRUE;
in lprint := FALSE
END PROC init output;
PROC basic out (INT CONST i): bas out (basic text (i) + " ") END PROC basic out;
PROC basic out (REAL CONST r): bas out (basic text (r) + " ") END PROC basic out;
PROC basic out (TEXT CONST t): bas out (basic text (t)) END PROC basic out;
PROC basic write (INT CONST i): bas out (basic text (i)) END PROC basic write;
PROC basic write (REAL CONST r): bas out (basic text (r)) END PROC basic write;
PROC basic write (TEXT CONST t): bas out (basic text ("""" + t + """")) END PROC basic write;
PROC bas out (TEXT CONST msg):
get cursor;
IF length (msg) > free
THEN IF first time
THEN first time := FALSE;
next line;
bas out (msg);
ELSE buffer := subtext (msg, 1, free);
IF sysout = ""
THEN out (buffer)
ELSE sysout write (buffer)
FI;
next line;
buffer := subtext (msg, free + 1);
bas out (buffer);
FI;
ELSE first time := TRUE;
IF sysout = ""
THEN out (msg)
ELSE sysout write (msg)
FI;
FI;
. free : screen width - x cursor + 1
END PROC bas out;
PROC tab (INT CONST n):
get cursor;
IF n <= 0
THEN tab position out of range
ELIF n > screen width
THEN tab (n MOD screen width);
ELIF x cursor > n
THEN next line;
tab (n);
ELIF sysout = ""
THEN cursor (n, y cursor);
ELSE buffer := (n - x cursor) * " ";
sysout write (buffer)
FI;
. tab position out of range :
IF x cursor <> 1 THEN next line FI;
write ("WARNUNG : TAB-Position <= 0");
next line;
END PROC tab;
PROC next zone:
get cursor;
IF x cursor > screen width - zone width
THEN next line;
ELIF sysout = ""
THEN free TIMESOUT " ";
ELSE buffer := free * " ";
sysout write (buffer)
FI;
. free : ((x cursor - 1) DIV zone width + 1) * zone width - x cursor + 1
END PROC next zone;
PROC next line :
IF sysout = ""
THEN next line on screen
ELSE line;
write (""); (* generates new record *)
output line := "";
FI;
. next line on screen:
line no INCR 1;
IF paging CAND line no > y size
THEN IF in last line
THEN warte;
ELSE out (""13""10"");
line no := y cursor + 1;
FI;
ELIF NOT paging
THEN char := incharety;
IF char <> ""
THEN IF char = "+"
THEN paging := TRUE
ELSE type (char)
FI
FI;
out (""13""10"")
ELSE out (""13""10"")
FI
. in last line :
get cursor;
y cursor = y size
. warte :
cursor (x size - 2, y size);
out (">>");
inchar (char);
IF char = ""13""
THEN next page
ELIF char = ""10""
THEN out (""8""8" "13""10"")
ELIF char = ""27""
THEN clear editor buffer;
errorstop (1, "")
ELIF char = "-"
THEN out (""8""8" "13""10"");
line no := 1;
paging := FALSE;
ELSE out (""8""8" "13""10"");
line no := 1;
FI;
. clear editor buffer:
REP UNTIL get charety = "" PER;
END PROC next line;
PROC next page:
IF sysout = ""
THEN out (""1""4"")
ELSE line
FI;
clear using;
line no := 1;
output line := "";
END PROC next page;
INT PROC pos (REAL CONST dummy): (* mo *)
cursor x pos
END PROC pos;
INT PROC pos (INT CONST dummy): (* mo *)
cursor x pos
END PROC pos;
INT PROC cursor x pos :
get cursor;
x cursor
END PROC cursor x pos;
INT PROC csrlin: (* mo *)
get cursor;
y cursor
END PROC csrlin;
PROC get cursor :
IF sysout = ""
THEN get cursor (x cursor, y cursor);
ELSE x cursor := LENGTH output line + 1;
FI;
END PROC get cursor;
INT PROC l pos (REAL CONST dummy): (* mo *)
l pos (0)
END PROC l pos;
INT PROC l pos (INT CONST dummy): (* mo *)
INT VAR lprint position :: 1;
IF exists (printfile name)
THEN disable stop;
FILE VAR printfile :: sequential file (modify, printfile name);
IF lines (printfile) > 0
THEN to line (printfile, lines (printfile));
lprint position := len (printfile) + 1
FI;
output (printfile)
FI;
lprint position
END PROC l pos;
PROC switch to printout file: (* mo *)
in lprint := TRUE;
old sysout := sysout;
careful sysout (printfile name);
END PROC switch to printout file;
PROC switch back to old sysout state: (* mo *)
IF in lprint
THEN careful sysout (old sysout);
in lprint := FALSE
FI
END PROC switch back to old sysout state;
PROC sysout write (TEXT CONST string):
check sysout;
write (string);
output line CAT string.
check sysout:
IF sysout <> last sysout file
THEN careful sysout (sysout)
FI.
END PROC sysout write;
PROC careful sysout (TEXT CONST new sysout): (* mo *)
IF new sysout <> ""
THEN disable stop;
FILE VAR outfile :: sequential file (modify, new sysout);
max line length (outfile, screen width);
last sysout file := sysout;
IF lines (outfile) > 0
THEN to line (outfile, lines (outfile));
read record (outfile, output line);
delete record (outfile)
ELSE output line := ""
FI;
sysout (new sysout);
write (output line);
ELSE sysout ("")
FI
END PROC careful sysout;
END PACKET basic output;
PACKET basic input (* Autor: R. Ruland *)
(* Stand: 27.10.1987/rr/mo *)
DEFINES init input,
read input,
check input,
assign input,
assign input line,
input ok,
input eof:
LET comma = ",",
quote = """",
wrong type = 1,
insufficient data = 2,
too much data = 3,
overflow = 4,
int overflow = 4,
real overflow = 6;
INT VAR input line pos, input error no;
BOOL VAR on terminal;
TEXT VAR input line :: "", previous input line := "", input value;
. first quote found : (input value SUB 1) = quote
.;
PROC init input :
input error no := 0;
input line pos := 0;
input line := "";
previous input line := "";
END PROC init input;
PROC read input (BOOL CONST cr lf, TEXT CONST msg, BOOL CONST question mark):
on terminal := sysout <> "" AND sysin = "";
check input error;
out string (msg);
IF question mark THEN out string ("? ") FI;
IF sysin <> ""
THEN getline (input line);
ELSE editget input line;
FI;
out string (input line);
IF crlf THEN out line FI;
input line pos := 0;
input error no := 0;
. check input error :
IF input error no = 0
THEN input line := "";
ELSE IF sysin = ""
THEN BOOL CONST old basic page := basic page;
basic page (FALSE);
IF cursor x pos <> 1 THEN next line FI;
basic out ("?Eingabe wiederholen ! (" + error text + ")");
next line;
basic page (old basic page);
ELSE errorstop (1080,"INPUT-Fehler (" + error text +
") : >" + input line + "<");
FI;
FI;
. error text :
SELECT input error no OF
CASE wrong type : "falscher Typ"
CASE insufficient data : "zu wenig Daten"
CASE too much data : "zu viele Daten"
CASE overflow : "Überlauf"
OTHERWISE : ""
END SELECT
. editget input line :
TEXT VAR exit char;
INT VAR x, y;
get cursor (x, y);
REP IF width - x < 1
THEN out (""13""10"");
get cursor (x, y)
FI;
editget (input line, max text length, width - x, "", "k", exit char);
cursor (x, y);
IF exit char = ""27"k"
THEN input line := previous input line;
ELSE previous input line := input line;
LEAVE editget input line;
FI;
PER;
END PROC read input;
PROC out string (TEXT CONST string) :
basic out (string);
IF on terminal THEN out (string) FI;
END PROC out string;
PROC out line :
next line;
IF on terminal THEN out (""13""10"") FI;
END PROC out line;
BOOL PROC check input (INT CONST type) :
get next input value;
input value := compress (input value);
set conversion (TRUE);
SELECT type OF
CASE 1 : check int input
CASE 2 : check real input
CASE 3 : check text input
END SELECT;
IF NOT last conversion ok THEN input error no := wrong type FI;
input error no = 0
. check int input :
IF input value <> ""
THEN disable stop;
INT VAR help int value;
help int value := int (input value);
IF is error CAND error code = int overflow
THEN clear error;
input error no := overflow;
FI;
enable stop;
FI;
. check real input :
IF input value <> ""
THEN disable stop;
REAL VAR help real value;
help real value := val (input value);
IF is error CAND (error code = real overflow
OR error code = int overflow) (* <-- Aufgrund eines Fehlers in 'real' *)
THEN clear error;
input error no := overflow;
FI;
enable stop;
FI;
. check text input :
(* IF input value = "" THEN input error no := wrong type FI; *)
IF NOT is quoted string CAND quote found
THEN input error no := wrong type
FI;
. is quoted string :
first quote found CAND last quote found
. last quote found :
(input value SUB LENGTH input value) = quote
. quote found :
pos (input value, quote) > 0
END PROC check input;
PROC assign input (INT VAR int value) :
get next input value;
int value := int (input value);
END PROC assign input;
PROC assign input (REAL VAR real value) :
get next input value;
real value := val (input value);
END PROC assign input;
PROC assign input (TEXT VAR string value) :
get next input value;
input value := compress (input value);
IF first quote found
THEN string value := subtext (input value, 2, LENGTH input value -1)
ELSE string value := input value
FI;
END PROC assign input;
PROC assign input line (TEXT VAR string line) :
string line := input line;
END PROC assign input line;
PROC get next input value : (* F27/rr *)
IF input line pos > LENGTH input line
THEN input value := "";
input error no := insufficient data;
ELSE IF next non blank char = quote
THEN get quoted string
ELSE get unquoted string
FI;
FI;
. next non blank char :
INT CONST next non blank char pos := pos (input line, ""33"", ""255"", input line pos + 1);
input line SUB next non blank char pos
. get quoted string :
INT CONST quote pos := pos (input line, quote, next non blank char pos + 1);
IF quote pos = 0
THEN input value := subtext (input line, next non blank char pos);
input line pos := LENGTH input line + 1;
input error no := wrong type;
ELSE input value := subtext (input line, next non blank char pos, quote pos);
input line pos := pos (input line, ""33"", ""255"", quote pos + 1);
IF input line pos = 0
THEN input line pos := LENGTH input line + 1;
ELIF (input line SUB input line pos) <> comma
THEN input error no := wrong type;
input line pos DECR 1;
FI;
FI;
. get unquoted string :
INT VAR comma pos := pos (input line, comma, input line pos + 1);
IF comma pos = 0
THEN input value := subtext (input line, input line pos + 1);
input line pos := LENGTH input line + 1;
ELSE input value := subtext (input line, input line pos + 1, comma pos - 1);
input line pos := comma pos;
FI;
END PROC get next input value;
BOOL PROC input ok:
IF input line pos <= LENGTH input line
THEN input error no := too much data FI;
input line pos := 0;
input error no = 0
END PROC input ok;
BOOL PROC input eof: input line = "" END PROC input eof;
END PACKET basic input;
PACKET basic std using io (* Autor: R. Ruland *)
(* Stand: 26.10.87/rr/mo *)
DEFINES init rnd:
PROC init rnd:
REAL VAR init;
REP read input (TRUE, "Startwert des Zufallszahlengenerators ? ", FALSE);
UNTIL check input (2) CAND input ok PER; (* F24/rr *)
assign input (init);
init rnd (init);
END PROC init rnd;
END PACKET basic std using io;