(***************************************************************************)
(* *)
(* Dritte von drei Dateien des EUMEL-BASIC-Systems *)
(* *)
(* Autor: Heiko Indenbirken *)
(* Überarbeitet von: Rudolf Ruland und Michael Overdick *)
(* *)
(* Stand: 27.10.1987 *)
(* *)
(***************************************************************************)
PACKET basic compiler DEFINES basic, (* Autor: Heiko Indenbirken *)
basic version: (* Stand: 27.10.1987/rr/mo *)
PROC basic version :
putline (""13" "15" BASIC - Compiler Version 1.1 (27.10.1987) "14"");
END PROC basic version;
LET compiler msg = " ******* ENDE DER UEBERSETZUNG *******",
compiler err msg = " Fehler entdeckt";
LET (* S y m b o l T y p e n *)
any = 0, const = 1, var = 2, array = 3, denoter = 5,
res word= 8, operator= 9, eos = 10, del =11, stat no = 12,
result const = 13, (* F3/rr *)
user fn = 20; (* DEF/mo *)
LET (* S y m b o l z e i c h e n *)
plus = 43, minus = 45, mult = 42,
div = 47, backslash = 92, exponent = 94,
equal = 61, semicolon = 59, comma = 44,
numbersign = 35, open bracket = 40, close bracket = 41,
eol = 13, eop = 14, mod op = 249;
LET (* Reservierte Worte *)
as s = 129, base s = 132, call s = 133, chain s = 135,
clear s = 138, close s = 139, common s = 140, data s = 144,
def s = 145, defdbl s = 146, defint s = 147, defsng s = 148,
defstr s = 149, dim s = 150, else s = 151, end s = 152,
eof s = 153, error s = 156, field s = 158, for s = 160,
get s = 162, gosub s = 164, goto s = 165, if s = 167, (* F2/rr *)
input s = 169, kill s = 173, let s = 176, line in s = 177,
lprint s = 180, lset s = 181, mid s = 182, name s = 185,
next s = 186, on s = 188, open s = 189, option s = 190,
print s = 193, put s = 194, rand s = 195, read s = 196,
rem s = 197, restore s = 198, resume s = 199, return s = 200,
rset s = 203, step s = 209, stop s = 210, swap s = 213,
tab s = 214, then s = 216, to s = 217, troff s = 218,
tron s = 219, using s = 220, wait s = 222, wend s = 223,
while s = 224, width s = 225, write s = 226, not = 250,
cls s = 227, usr = 234, sub = 235; (* mo *)
LET nil = "",
intern error = 51;
LET SYMBOL = STRUCT (TEXT name, INT no, type, ADDRESS adr, DTYPE data);
ADDRESS CONST niladr :: LOC -4;
SYMBOL CONST nilsymbol :: SYMBOL : (nil, any, any, nil adr, void type);
SYMBOL VAR symb;
BOOL VAR found;
OPN VAR opn;
TEXT OP NAME (SYMBOL CONST val):
IF val.type = const
THEN constant value
ELIF val.type = stat no
THEN text (val.no)
ELSE val.name FI .
constant value:
IF val.data = int type AND length (val.name) = 2
THEN text (val.name ISUB 1)
ELIF val.data = real type AND length (val.name) = 8
THEN text (val.name RSUB 1)
ELSE val.name FI .
END OP NAME;
PROC careful error (INT CONST no, TEXT CONST name, addition): (* DEF/mo *)
IF at end of statement
THEN basic error (no, name, addition)
ELSE basic error without leaving statement
FI.
at end of statement:
symb.type = eos.
basic error without leaving statement:
basic error (no, name, addition, FALSE);
error no INCR 1.
END PROC careful error;
(* P r e c o m p i l e r *)
PROC next symbol:
symb.adr := niladr;
next symbol (symb.name, symb.no, symb.type, symb.data);
IF symb.no = end symbol AND symb.type = res word
THEN symb.no := -symb.no;
symb.type := eos;
FI
END PROC next symbol;
PROC skip (INT CONST symbol, type):
IF symb.type = type AND symb.no = symbol
THEN next symbol
ELSE basic error (2, NAME symb, name of (symbol) + " erwartet") FI .
END PROC skip;
PROC get letter (SYMBOL VAR symbol):
IF symb.type = var AND (LENGTH symb.name) = 1
THEN symbol := symb;
next symbol
ELSE basic error (2, NAME symb, "Buchstabe erwartet, " + type of (symb.type) + " gefunden") FI .
END PROC get letter;
PROC get var (SYMBOL VAR symbol):
IF symb.type = var
THEN variable (symbol)
ELIF symb.type = array
THEN array var (symbol)
ELSE basic error (2, NAME symb, "Variable erwartet, " + type of (symb.type) + " gefunden") FI .
END PROC get var;
PROC get expr (SYMBOL VAR symbol):
get expression (symbol, 0)
END PROC get expr;
PROC get const (SYMBOL VAR symbol, DTYPE CONST data):
IF symb.type = const
THEN symbol := symb;
declare const (symbol, data); (* F3/rr *)
next symbol
ELSE basic error (2, NAME symb, "Konstante erwartet, " + type of (symb.type) + " gefunden") FI .
END PROC get const;
PROC get var (SYMBOL VAR symbol, DTYPE CONST data):
get var (symbol);
convert (symbol, data)
END PROC get var;
PROC get expr (SYMBOL VAR symbol, DTYPE CONST data):
get expression (symbol, 0);
convert (symbol, data)
END PROC get expr;
PROC get expression (SYMBOL VAR result, INT CONST last prio):
get single result;
WHILE symb.type = operator AND higher priority
REP get dyadic operand;
gen dyadic operation
PER .
get single result:
INT VAR prio;
SELECT symb.type OF
CASE var: variable (result)
CASE array: array var (result)
CASE const: get const
CASE operator: get monadic operator
CASE res word: basic function (result)
CASE user fn: user function (result) (* DEF/mo *)
OTHERWISE get bracket END SELECT .
get const:
result := symb;
declare const (result, result. data); (* F3/rr *)
next symbol .
get monadic operator:
get operator;
prio := monadic op prio; (* mo *)
get monadic operand;
generate monadic operator .
monadic op prio: (* mo *)
IF op no = not
THEN 6
ELSE 12
FI.
get monadic operand:
SYMBOL VAR operand;
next symbol;
get expression (operand, prio).
generate monadic operator:
(* Mögliche Ops: +, - und NOT *)
parameter (1, operand.data, const, operand.adr);
parameter (2, operand.data, var, next local adr (operand.data));
parameter (3, void type, const, nil adr);
IF op no = plus
THEN result := operand
ELIF op no = minus
THEN generate minus op
ELIF op no = not
THEN generate not op
ELSE basic error (2, op name, "Kein monadischer Operator") FI .
generate minus op:
IF operand.data = int type
THEN apply (1, 2, int minus)
ELIF operand.data = real type
THEN apply (1, 2, real minus)
ELSE basic error (82, op name, NAME operand + " : " + dump (operand.data)) FI;
result := SYMBOL:(op name, 0, result const, local adr, operand.data) .
generate not op:
IF operand.data = int type
THEN apply (1, 1, int not opn)
ELIF operand.data = real type
THEN apply (1, 1, real not opn)
ELSE basic error (82, op name, NAME operand + " : " + dump (operand.data)) FI;
result := SYMBOL:(op name, 0, result const, local adr, operand.data) .
get operator:
INT CONST op no :: symb.no;
TEXT CONST op name :: symb.name .
higher priority:
get operator;
prio := dyadic op prio;
prio > last prio .
dyadic op prio:
IF is bool op (op no) THEN bool op prio
ELIF op no = plus OR op no = minus THEN 8
ELIF op no = mod op THEN 9
ELIF op no = backslash THEN 10
ELIF op no = mult OR op no = div THEN 11
ELIF op no = exponent THEN 13
ELSE (* relational operator *) 7
FI.
bool op prio:
256 - op no.
get bracket:
IF symb.type = del AND symb.no = open bracket
THEN next symbol
ELSE basic error (22, NAME symb, "") FI;
get expression (result, 0);
skip (close bracket, del) .
get dyadic operand:
next symbol;
get expression (operand, prio) .
gen dyadic operation:
convert operands;
identify dyadic operator;
generate dyadic operator .
convert operands:
DTYPE CONST op type :: type of operation;
convert (result, op type);
convert (operand, op type) .
type of operation:
IF is bool op (op no)
THEN int type
ELIF result.data = operand.data
THEN result.data
ELSE real type FI .
identify dyadic operator:
BOOL VAR local found;
OPN VAR local opn;
DTYPE VAR data;
parameter (1, result.data, const, result.adr);
parameter (2, operand.data, const, operand.adr);
identify (op no, 1, 2, local opn, local found);
IF NOT local found
THEN basic error (83, symbol of (op no),
NAME result + " : " + dump (result.data) + " und " +
NAME operand + " : " + dump (operand.data))
ELSE data := dtype (3) FI .
generate dyadic operator:
declare (3, var);
define (3, next local adr (data));
apply (3, push);
apply (1, 2, local opn);
result := SYMBOL:(op name, 0, result const, local adr, data) .
END PROC get expression;
PROC variable (SYMBOL VAR symbol):
symbol := symb;
next symbol;
IF known (symbol.no)
THEN get adr from table
ELSE declare var (symbol, nil) FI .
get adr from table:
TEXT VAR defined dim;
remember (symbol.no, symbol.type, symbol.adr, symbol.data, defined dim) .
END PROC variable;
PROC array var (SYMBOL VAR symbol field):
(* Aufbau der Dimensionsangaben in der Symboltabelle *)
(* limit 1 [limit 2]... Basis Elemente *)
(* jeweils als 2 Byte Integer/Text *)
(* Die Dimension ist dann DIM/2-2 *)
ROW 100 SYMBOL VAR indizes;
TEXT VAR limits;
INT VAR dim;
symbol field := symb; next symbol;
get paramfield (indizes, dim, int type);
IF known (symbol field.no)
THEN check field dim and data
ELSE declare new field FI;
generate field index .
check field dim and data:
INT VAR type;
DTYPE VAR data;
remember (symbol field.no, type, symbol field.adr, data, limits);
IF old dim <> dim
THEN basic error (84, symbol field.name, "Dimensioniert in " + text (old dim) + " Dimensionen, gefundene Anzahl Indizes: " + text (dim))
ELIF NOT (symbol field.data = data)
THEN basic error (intern error, symbol field.name, dump (data) + " <=> " + dump (symbol field.data))
ELIF NOT (symbol field.type = type)
THEN basic error (intern error, symbol field.name, "Feld erwartet, " + type of (type) + " gefunden") FI .
old dim: (length (limits) DIV 2) - 2 .
declare new field:
limits := dim * ""10""0"" + mki (array base) +
mki ((10 - array base + 1)**dim);
declare var (symbol field, limits) .
generate field index:
init field subscription;
FOR j FROM 1 UPTO dim
REP increase field index;
calc index length and limit;
calculate field pointer;
symbol field.adr := REF pointer
PER .
init field subscription:
ADDRESS VAR pointer :: next local adr (row type),
index adr :: next local adr (int type);
INT VAR j, elem length :: (limits ISUB (dim+2)) * typesize (symbol field.data),
elem limit,
elem offset :: 1 - (limits ISUB (dim+1));
BOOL CONST base zero := elem offset = 1 .
increase field index:
IF base zero
THEN parameter (1, int type, const, index.adr);
parameter (2, int type, const, one value);
parameter (3, int type, var, index adr);
parameter (4, void type, const, nil adr);
apply (1, 3, int add);
ELSE index adr := index.adr FI .
index: indizes [j] .
calc index length and limit:
elem limit := (limits ISUB j) + elem offset;
elem length := elem length DIV elem limit .
calculate field pointer:
parameter (1, int type, const, symbol field.adr);
parameter (2, int type, const, index adr);
parameter (3, int type, elem length);
parameter (4, int type, elem limit);
parameter (5, int type, const, pointer);
parameter (6, void type, const, nil adr);
apply (1, 5, subscript);
END PROC array var;
PROC get paramfield (ROW 100 SYMBOL VAR params list, INT VAR no):
skip (open bracket, del);
FOR no FROM 1 UPTO 100
REP get expression (params list [no], 0);
IF symb.type = del AND symb.no = close bracket
THEN next symbol;
LEAVE get paramfield
ELSE skip (comma, del) FI
PER .
END PROC get paramfield;
PROC get paramfield (ROW 100 SYMBOL VAR params list, INT VAR no, DTYPE CONST data):
skip (open bracket, del);
FOR no FROM 1 UPTO 100
REP get expression (params list [no], 0);
convert (params list [no], data);
IF symb.type = del AND symb.no = close bracket
THEN next symbol;
LEAVE get paramfield
ELSE skip (comma, del) FI
PER .
END PROC get paramfield;
PROC examine access rights (ROW 100 SYMBOL VAR params list, INT CONST no):
INT VAR j;
FOR j FROM 1 UPTO no REP
IF params list [j].type = const OR params list [j].type = result const
THEN IF access (j) = 2
THEN basic error (103, NAME params list [j], "im " + text (j)
+ ". Eintrag der Parameterliste")
FI
FI
PER
END PROC examine access rights;
PROC basic function (SYMBOL VAR ftn): (* Änd. 11.08.87, mo *)
init and check function;
IF symb.type = del AND symb.no = open bracket
THEN get paramfield (params list, number params);
FI;
apply function .
init and check function:
ROW 100 SYMBOL VAR params list;
INT VAR number params :: 0;
BOOL CONST is usr :: symb.no = usr;
IF is usr
THEN check proc name
FI;
ftn := symb;
next symbol .
check proc name:
next symbol;
IF symb.type = array
THEN symb.name := subtext (symb.name, 1, LENGTH symb.name-2)
ELIF symb.type <> var
THEN basic error (2, NAME symb, "Prozedurname erwartet")
FI.
apply function:
OPN VAR ftn local opn;
BOOL VAR ftn found;
INT CONST result :: number params+1;
INT VAR j;
FOR j FROM 1 UPTO number params
REP parameter (j, params list [j].data, const, params list [j].adr) PER;
IF is usr
THEN identify proc;
examine access rights (params list, number params);
ELSE identify function
FI;
ftn.adr := next local adr (ftn.data);
declare (result, var);
define (result, ftn.adr);
apply (result, push);
apply (1, number params, ftn local opn).
identify proc:
identify (deshift (ftn.name), 1, number params, ftn local opn, ftn found);
ftn.data := dtype (result);
IF NOT ftn found
THEN basic error (99, ftn.name, "Parameter angegeben: " + param list (1, number params))
ELIF ftn.data = void type
THEN basic error (5, ftn.name, "Die Prozedur liefert keinen Wert")
ELIF NOT (ftn.data = int type) AND NOT (ftn.data = real type) AND NOT (ftn.data = text type)
THEN basic error (5, ftn.name, "Der Typ des Resultats ist nicht erlaubt, gefunden: "
+ dump (dtype (result)))
FI.
identify function:
identify (ftn.no, 1, number params, ftn local opn, ftn found);
IF ftn found
THEN ftn.data := dtype (result)
ELIF is basic function (ftn.no)
THEN basic error (98, ftn.name, "Argument(e) angegeben: " + param list (1, number params))
ELSE basic error (22, ftn.name, "Anweisung(sbestandteil) gefunden")
FI.
END PROC basic function;
PROC user function (SYMBOL VAR result): (* DEF/mo *)
check if function defined;
get arguments if expected;
gosub (user function label);
copy result.
check if function defined:
TEXT CONST scope :: name of (symb.no) + "?";
IF NOT known (symb.no)
THEN basic error (18, symb.name, "")
ELIF scanner scope = scope
THEN basic error (85, symb.name, "")
FI.
get arguments if expected:
INT VAR param counter;
TEXT VAR dim text;
result := symb;
remember (symb.no, symb.type, result.adr, result.data, dim text);
INT VAR number of params :: LENGTH dim text DIV 2 - 1;
next symbol;
IF number of params > 0
THEN get all arguments
ELIF symb.no = open bracket AND symb.type = del
THEN basic error (5, symb.name, "Kein Argument erwartet")
FI.
get all arguments:
IF symb.no <> open bracket OR symb.type <> del
THEN basic error (5, NAME symb, text (number of params) + " Argument(e) erwartet")
FI;
next symbol;
FOR param counter FROM 2 UPTO number of params REP
get one argument;
skip comma;
PER;
get one argument;
skip close bracket.
get one argument:
SYMBOL VAR ftn param;
ftn param.no := dim text ISUB param counter;
remember (ftn param.no, ftn param.type, ftn param.adr, ftn param.data, ftn param.name);
IF ftn param.type <> var
THEN basic error (intern error, name of (ftn param.no), "Parametereintrag fehlerhaft")
FI;
SYMBOL VAR expr res;
get expr (expr res, ftn param.data);
apply move (ftn param.adr, expr res.adr, ftn param.data).
skip comma:
IF symb.no = close bracket AND symb.type = del
THEN basic error (5, symb.name, text (number of params) + " Argumente erwartet")
ELIF symb.no <> comma OR symb.type <> del
THEN basic error (2, NAME symb, " , in Argumentenliste erwartet")
FI;
next symbol.
skip close bracket:
IF symb.no = comma AND symb.type = del
THEN basic error (5, symb.name, "Nur " + text (number of params) + " Argument(e) erwartet")
ELIF symb.no <> close bracket OR symb.type <> del
THEN basic error (2, NAME symb, " ) nach Argumentenliste erwartet")
FI;
next symbol.
user function label:
label list [dim text ISUB 1].
copy result :
apply move (next local adr (result.data), result.adr, result.data);
result.adr := local adr.
END PROC user function;
PROC apply move (ADDRESS CONST dest adr, source adr, DTYPE CONST datype):
parameter (1, datype, var, dest adr);
parameter (2, datype, const, source adr);
parameter (3, void type, const, nil adr);
IF datype = int type
THEN apply (1, 2, int move)
ELIF datype = real type
THEN apply (1, 2, real move)
ELIF datype = text type
THEN apply (1, 2, text move)
ELSE basic error (2, "=", "Unbekannter Datentyp: " + dump (datype)) FI .
END PROC apply move;
PROC convert (SYMBOL VAR symbol, DTYPE CONST to data): (* F3/rr *)
IF to data = from data
THEN
ELIF symbol.type = const
THEN declare const (symbol, to data)
ELIF to data = int type
THEN make int
ELIF to data = real type
THEN make real
ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI .
from data : symbol.data .
make real :
IF symbol.data = int type
THEN parameter (1, symbol.data, const, symbol.adr);
parameter (2, real type, var, next local adr (real type));
parameter (3, void type, const, nil adr);
apply (1, 1, int to real);
symbol.adr := local adr;
symbol.data := real type
ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI .
make int :
IF symbol.data = real type
THEN parameter (1, symbol.data, const, symbol.adr);
parameter (2, int type, var, next local adr (int type));
parameter (3, void type, const, nil adr);
apply (1, 1, real to int);
symbol.adr := local adr;
symbol.data := int type
ELSE basic error (13, NAME symbol, dump (to data) + " erwartet, " + dump (from data) + " gefunden") FI .
END PROC convert;
PROC declare const (SYMBOL VAR symbol constant, DTYPE CONST data):
convert symb value;
IF new constant
THEN declare this constant
ELSE get table entry FI .
convert symb value:
IF data = symbol constant.data
THEN LEAVE convert symb value
ELIF data = int type AND symbol constant.data = real type
THEN symbol constant.name := mki (symbol constant.name RSUB 1);
ELIF data = real type AND symbol constant.data = int type
THEN symbol constant.name := mkd (symbol constant.name ISUB 1);
ELIF data = text type AND symbol constant.data = int type
THEN symbol constant.name := text (symbol constant.name ISUB 1)
ELIF data = text type AND symbol constant.data = real type
THEN symbol constant.name := text (symbol constant.name RSUB 1)
ELSE basic error (13, NAME symbol constant, dump (data) + " erwartet, "
+ dump (symbol constant.data) + " gefunden") FI;
symbol constant.data := data .
new constant:
(* Konstanten werden wie folgt abgelegt: *)
(* INT: § HL *)
(* REAL: § MMMMMMME *)
(* TEXT: § Text *)
put name ("§ " + symbol constant.name, symbol constant.no);
NOT known (symbol constant.no) .
declare this constant:
IF data = int type
THEN allocate denoter (symbol constant.adr, symbol constant.name ISUB 1)
ELIF data = real type
THEN allocate denoter (symbol constant.adr, symbol constant.name RSUB 1)
ELIF data = text type
THEN allocate denoter (symbol constant.adr, symbol constant.name) FI;
recognize (symbol constant.no, const, symbol constant.adr, data, nil) .
get table entry:
INT VAR table type;
TEXT VAR table dim;
remember (symbol constant.no, table type, symbol constant.adr, symbol constant.data, table dim);
IF table dim <> nil
THEN basic error (intern error, NAME symbol constant, "Dimension in Tabelle ungleich niltext")
ELIF NOT (symbol constant.data = data)
THEN basic error (intern error, NAME symbol constant, "Falscher DTYPE in Tabelle, erw: " + dump (data)
+ ", gef: " + dump (symbol constant.data)) FI .
END PROC declare const;
PROC declare var (SYMBOL VAR symbol var, TEXT CONST dim): (* F4/rr *)
allocate variable;
recognize (symbol var.no, symbol var.type, symbol var.adr, symbol var.data, dim) .
allocate variable :
symbol var.adr := next local adr (symbol var.data);
IF dim <> nil
THEN INT VAR index;
ADDRESS VAR dummy;
FOR index FROM 2 UPTO no of elements
REP dummy := next local adr (symbol var.data) PER;
FI .
no of elements:
(dim ISUB (LENGTH dim DIV 2)) .
END PROC declare var;
PROC parameter (INT CONST p, DTYPE CONST d type, INT CONST value):
declare (p, d type);
declare (p, denoter);
define (p, value);
END PROC parameter;
PROC apply (INT CONST first, number params, TEXT CONST name):
identify (name, first, number params, opn, found);
IF NOT found
THEN errorstop (1051, "PROC " + name + ", Parameter: " + param list (first, number params) + ", nicht gefunden!") FI;
apply (first, number params, opn)
END PROC apply;
PROC clear local stack : (* F4/rr *)
define local variables;
clear index;
define (rep); index incr one;
if local storage less or equal index then goto end;
get cell address;
clear cell;
apply (rep);
define (end);
clear cell address;
. define local variables :
LABEL VAR rep, end;
ADDRESS VAR index;
declare (rep); declare (end);
allocate variable (index, type size (int type));
. clear index :
parameter (1, int type, var, index);
apply (1, 1, clear);
. index incr one :
parameter (1, int type, var, index);
apply (1, 1, incone);
. if local storage less or equal index then goto end :
parameter (1, int type, const, loc storage);
parameter (2, int type, const, index);
apply (1, 2, lsequ);
apply (end, TRUE);
. get cell address :
parameter (1, int type, const, LOC 2);
parameter (2, int type, const, index);
parameter (3, int type, 1);
parameter (4, int type, 16000);
parameter (5, int type, const, LOC 0);
apply (1, 5, subscript);
. clear cell :
parameter (1, int type, var, REF LOC 0);
apply (1, 1, clear);
. clear cell address :
parameter (1, int type, var, LOC 0);
apply (1, 1, clear);
parameter (1, int type, var, LOC 1);
apply (1, 1, clear);
END PROC clear local stack;
(* M a i n *)
(* ̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃̃ *)
(* C o m p i l e r *)
(* ***** G l o b a l e V a r i a b l en ***** *)
INT VAR end symbol :: 0, error no :: 0, act stat no :: 0, array base :: 0;
BOOL VAR basic trace, was warning;
ADDRESS VAR data pos, data text;
(* Globale Operationen *)
OPN VAR basic init, basic frame, basic module, ret, equal op,
int minus, real minus, int not opn, real not opn,
trace op, ln op, push,
int incr, real incr, int add,
int move, real move, text move, test,
real to int, int to real, subscript,
clear, incone, lsequ, (* F4/rr *)
basic out text;
(* Parameter VOID *)
init ("RTN", 1, 0, ret);
(* Parameter INT *)
declare (1, int type);
init ("intnot", 1, 1, int not opn); (* mo *)
init ("PP", 1, 1, push);
init ("LN", 1, 1, ln op);
init ("real", 1, 1, int to real);
init ("TEST", 1, 1, test);
init ("CLEAR", 1, 1, clear);
init ("INCONE", 1, 1, incone);
init ("trace", 1, 1, trace op);
(* Parameter INT INT *)
declare (2, int type);
init ("COMPLINT", 1, 2, int minus);
init ("MOVE", 1, 2, int move);
init ("INC", 1, 2, int incr);
init ("EQU", 1, 2, equal op);
init ("LSEQU", 1, 2, lsequ);
(* Parameter INT INT INT *)
declare (3, int type);
init ("ADD", 1, 3, int add);
(* Paramter REAL *)
declare (1, real type);
init ("realnot", 1, 1, real not opn); (* mo *)
init ("cint", 1, 1, real to int);
(* Parameter REAL REAL *)
declare (2, real type);
init ("COMPLREAL", 1, 2, real minus);
init ("FMOVE", 1, 2, real move);
init ("INCR", 1, 2, real incr);
(* Parameter TEXT *)
declare (1, text type);
init ("basicout", 1, 1, basic out text);
(* Paramter TEXT TEXT *)
declare (2, text type);
init ("TMOVE", 1, 2, text move);
(* Parameter ADDRESS INT DENOTER DENOTER ADDRESS *)
declare (3, denoter);
declare (4, denoter);
init ("SUBSCRIPT", 1, 5, subscript);
PROC init (TEXT CONST name, INT CONST local from, number params, OPN VAR local opn):
identify (name, local from, number params, local opn, found);
IF NOT found
THEN errorstop (1051, "PROC init (TC, IC, IC, OPN VAR): OPN für """ + name + """ nicht gefunden") FI
END PROC init;
(* Runtime Konstanten *)
ADDRESS VAR true value, false value, niltext value,
zero value, one value, two value, three value,
comma value, int one value, real one value,
loc storage; (* F4/rr *)
(* +++++ Globale Variablen +++++ *)
BOOL VAR proc found;
INT VAR deftype, field elems, i, params;
ROW 100 SYMBOL VAR param;
SYMBOL VAR base size, begin range, end range, expr result, field, filename,
from, len, image, label, old name, new name,
question, size, tab pos, var result;
TEXT VAR constant, field size, proc name;
(* Label-Verwaltung *)
LET label list size = 4100;
BOUND ROW label list size LABEL VAR label list;
DATASPACE VAR label ds;
INITFLAG VAR label init :: FALSE;
INT VAR last label no;
(* ***** I n t e r f a c e P r o z d u r e n ***** *)
PROC basic:
basic (last param)
END PROC basic;
PROC basic (TEXT CONST basic file name):
basic (basic file name, nil)
END PROC basic;
PROC basic (TEXT CONST basic file name, prog name):
IF NOT exists (basic file name)
THEN errorstop ("""" + basic file name + """ gibt es nicht")
ELSE FILE VAR basic file :: sequential file (modify, basic file name); (* F5/rr *)
headline (basic file, basic file name);
last param (basic file name);
basic (basic file, prog name)
FI;
END PROC basic;
PROC basic (FILE VAR source file, TEXT CONST prog name):
IF prog name <> nil CAND prog name is not a tag (* F5/rr *)
THEN errorstop ("unzulässiger Programmname : """ + prog name + """");
FI;
modify (source file); (* F5/rr *)
disable stop;
init label table;
store status;
coder on (data allocation by coder);
compile (source file, progname);
restore status;
start basic prog .
prog name is not a tag : (* F5/rr *)
LET tag = 1;
INT VAR symbol type;
TEXT VAR symbol name;
scan (prog name);
next symbol (symbol name, symbol type);
symbol name <> prog name OR symbol type <> tag .
init label table:
IF NOT initialized (label init)
THEN label ds := nilspace;
label list := label ds;
FI .
store status:
INT CONST source line :: line no (source file),
source col :: col (source file);
BOOL CONST check status :: check;
check on .
restore status:
to line (source file, source line);
col (source file, source col);
IF NOT check status
THEN check off FI .
start basic prog:
IF error no > 0 OR is error
THEN basic error end
ELSE normal end
FI;
close (source file) .
basic error end:
coder off (FALSE, FALSE, nop);
IF is error
THEN put error;
clear error
ELSE display (""13""10""10""); (* F20/rr *)
display (text (error no) + compiler err msg);
display (""13""10""10"");
display (compiler msg);
display (""13""10"");
IF sysout <> ""
THEN line (2);
put (text (error no) + compiler err msg);
line (2);
put (compiler msg);
line
FI
FI;
show file and error .
show file and error: (* F20/rr *)
IF anything noted CAND command dialogue
THEN noteedit (source file);
FI;
errorstop (nil) .
normal end:
IF prog name = nil
THEN run basic proc
ELSE insert basic proc FI;
IF warnings AND was warning
THEN show file and error
FI.
run basic proc:
coder off (FALSE, TRUE, basic frame);
display (""13""10"") .
insert basic proc:
coder off (TRUE, TRUE, basic frame);
coder on (data allocation by coder);
coder off (FALSE, FALSE, basic init);
display (""13""10"") .
END PROC basic;
PROC compile (FILE VAR source file, TEXT CONST progname):
enable stop;
init compiler;
init basic prog;
begin scanning (source file);
next symbol;
get statement group (eop);
end compiling .
init compiler:
end symbol := 0;
error no := 0;
act stat no := 0;
array base := 0;
basic trace := FALSE;
was warning := FALSE;
init storage;
init label;
init data;
init table .
init label:
TEXT VAR local stat no;
INT VAR stat nos;
init stat no (source file, error no); (* F21/rr *)
IF error no > 0 THEN LEAVE compile FI;
all stat no (local stat no, stat nos);
FOR i FROM 1 UPTO stat nos
REP declare (label list [i]) PER;
last label no := stat nos. (* DEF/mo *)
init basic prog:
LIB VAR packet;
declare (basic packet name, packet);
define (packet);
parameter (1, void type, const, nil adr);
declare (basic init);
IF progname = nil
THEN declare (basic frame)
ELSE declare (progname, 1, 0, basic frame) FI;
declare (basic module);
declare runtime const;
declare basic init;
declare basic frame;
declare basic module .
basic packet name:
IF progname <> ""
THEN "BASIC." + progname
ELSE "BASIC"
FI.
declare runtime const:
allocate variable (data text, type size (text type));
allocate variable (data pos, type size (int type));
allocate variable (loc storage, type size (int type)); (* F4/rr *)
allocate denoter (true value, 0);
allocate denoter (false value, -1);
allocate denoter (niltext value, nil);
allocate denoter (one value, 1);
allocate denoter (two value, 2);
allocate denoter (three value, 3);
allocate denoter (real one value, 1.0);
allocate denoter (comma value, ",");
zero value := true value;
int one value := one value .
declare basic init:
begin module;
define (basic init, 4);
parameter (1, text type, var, data text);
parameter (2, int type, var, data pos);
apply (1, 2, "initdata");
parameter (1, void type, const, nil adr);
apply (1, 0, ret);
end module .
declare basic frame:
begin module;
define (basic frame, 4);
IF prog name = nil
THEN parameter (1, void type, const, nil adr);
apply (1, 0, basic init);
FI;
declare (1, int type);
declare (1, const);
define (1, 0);
parameter (2, void type, const, nil adr);
apply (1, 1, ln op);
apply (1, 0, "disablestop");
apply (1, 0, "startbasic");
parameter (1, int type, var, data pos);
parameter (2, int type, const, one value);
parameter (3, void type, const, nil adr);
apply (1, 2, int move);
parameter (1, void type, const, nil adr);
apply (1, 0, basic module);
apply (1, 0, "endbasic");
parameter (1, void type, const, nil adr);
apply (1, 0, ret);
end module .
declare basic module:
LABEL VAR start lab;
begin module;
define (basic module);
declare (start lab);
apply (1, 0, "enablestop");
gosub (start lab);
parameter (1, void type, const, nil adr);
apply (1, 0, "returnerror"); (* mo *)
define (start lab);
clear local stack . (* F4/rr *)
end compiling:
parameter (1, void type, const, nil adr);
apply (1, 0, ret);
define (loc storage, local storage - 1); (* F4/rr *)
set length of local storage (basic module, max (2, local storage)); (* F4/rr *)
IF error no = 0
THEN end module FI .
END PROC compile;
PROC get statement group (INT CONST new symbol):
(* 'get statement group' compiliert das ganze Programm bis zum Auftreten *)
(* von 'end symbol' *)
disable stop;
new end symbol;
get all basic lines;
old end symbol .
new end symbol:
INT CONST old symbol :: end symbol;
end symbol := new symbol .
old end symbol:
end symbol := old symbol .
get all basic lines:
REP get basic line;
IF is error
THEN error handling
ELIF symb.type = eos
THEN check this eos FI
PER .
error handling: (* F20/rr *)
IF error in basic program
THEN error no INCR 1
ELIF end of source file
THEN clear error;
LEAVE get all basic lines
ELIF halt from terminal
THEN LEAVE get statement group
ELSE error no INCR 1;
handle internal error;
LEAVE get statement group
FI;
clear error;
scope compulsory (TRUE); (* DEF/mo *)
set scope (""); (* DEF/mo *)
next statement;
next symbol .
error in basic program:
errorcode = 101.
end of source file:
errorcode = 99.
halt from terminal:
errorcode = 1.
handle internal error : (* F20/rr *)
TEXT VAR error :: "BASIC-Compiler ERROR";
IF errorcode <> 0
THEN error CAT " #" + text (errorcode) FI;
IF errorline > 0
THEN error CAT " at " + text (errorline) FI;
error CAT " : ";
error CAT errormessage;
IF sysout <> "" THEN putline (error) FI;
note (error);
noteline;
clear error;
errorstop (error).
check this eos:
IF symb.no = eol
THEN next symbol
ELIF symb.no = -new symbol OR symb.no = eop
THEN LEAVE get all basic lines (* mo *)
ELSE basic error (intern error, NAME symb, "EOL erwartet, " +
type of (symb.type) + " gefunden")
FI .
END PROC get statement group;
PROC get basic line (INT CONST new symbol):
(*Die Abbruchbedingungen werden neu gesetzt und bei Verlassen der *)
(*Prozedur zurückgesetzt. *)
disable stop;
INT CONST old symbol :: end symbol;
end symbol := new symbol;
get basic line;
end symbol := old symbol .
END PROC get basic line;
PROC get basic line:
(* 'get basic line' behandelt genau eine Zeile mit Zeilennummer. *)
enable stop;
IF symb.type = stat no
THEN gen stat no (symb.no) FI;
REP get one basic statement PER .
get one basic statement:
(* 'get one basic statement' behandelt genau ein Statement. *)
IF symb.type = eos
THEN get end of statement
ELIF symb.type = res word OR symb.type = var OR symb.type = array
THEN get one statement
ELSE basic error (2, NAME symb, type of (symb.type) + " ohne Zusammenhang") FI .
get end of statement:
IF symb.no = eos
THEN next symbol
ELSE LEAVE get basic line FI .
get one statement:
IF symb.type = res word
THEN get res word statement
ELIF symb.type = var OR symb.type = array
THEN let statement
FI;
skip comma if else expected;
IF symb.type <> eos
THEN basic error (2, NAME symb, "EOS erwartet, " + type of (symb.type) + " gefunden")
FI.
skip comma if else expected:
IF end symbol = else s AND symb.type = del AND symb.no = comma
THEN next symbol;
IF symb.type <> eos OR symb.no <> -else s
THEN basic error (2, NAME symb, "ELSE erwartet")
FI
FI.
get res word statement:
SELECT symb.no OF
CASE as s : basic error (90, symb.name, "")
CASE base s : basic error (91, symb.name, "")
CASE call s,
chain s : call statement
CASE clear s : not implemented
CASE close s : not implemented
CASE cls s : cls statement (* mo *)
CASE common s : not implemented
CASE data s : data statement
CASE def s : def statement (* mo *)
CASE defint s,
defdbl s,
defsng s,
defstr s : def type statement
CASE dim s : dim statement
CASE else s : basic error (92, symb.name, "")
CASE end s : end statement
CASE error s : error statement
CASE field s : not implemented
CASE for s : for statement
CASE get s : not implemented
CASE gosub s : gosub statement
CASE goto s : goto statement
CASE if s : if statement
CASE input s : input statement
CASE kill s : kill statement
CASE let s : let statement
CASE line in s: line statement
CASE lprint s : lprint statement (* mo *)
CASE l set s : l set statement
CASE mid s : mid statement
CASE name s : name statement
CASE next s : basic error (1, symb.name, "")
CASE on s : on statement
CASE open s : not implemented
CASE option s : option statement
CASE print s : print statement
CASE put s : not implemented
CASE rand s : randomize statement
CASE read s : read statement
CASE rem s : rem statement
CASE restore s: restore statement
CASE resume s : not implemented
CASE return s : return statement
CASE r set s : r set statement
CASE step s : basic error (93, symb.name, "")
CASE stop s : stop statement
CASE sub : basic error (101, symb.name, "")
CASE swap s : swap statement
CASE tab s : basic error (94, symb.name, "")
CASE then s : basic error (95, symb.name, "")
CASE to s : basic error (96, symb.name, "")
CASE troff s : troff statement
CASE tron s : tron statement
CASE using s : basic error (97, symb.name, "")
CASE wait s : not implemented
CASE wend s : basic error (30, symb.name, "")
CASE while s : while statement
CASE width s : width statement
CASE write s : write statement
OTHERWISE basic error (104, symb.name, "") END SELECT.
not implemented:
basic error (100, symb.name, "").
call statement:
(*CALL <proc name> [(<argument list>)] *)
next symbol;
get proc name;
get proc parameter;
apply proc .
get proc name:
proc name := symb.name;
IF symb.type = array
THEN proc name := subtext (proc name, 1, LENGTH proc name-2) FI;
next symbol .
get proc parameter:
params := 0;
IF symb.type = del AND symb.no = open bracket
THEN get paramfield (param, params) FI .
apply proc:
OPN VAR proc opn;
FOR i FROM 1 UPTO params
REP parameter (i, param [i].data, const, param [i].adr) PER;
identify (deshift (proc name), 1, params, proc opn, proc found);
IF NOT proc found
THEN basic error (99, proc name, "Parameter angegeben: " + param list (1, params))
ELIF result found
THEN basic error (5, proc name, "Kein Resultat erlaubt (gefunden: " + dump (result data) + ")")
FI;
examine access rights (param, params);
parameter (params+1, void type, const, nil adr);
apply (1, params, proc opn) .
result found:
NOT (result data = void type) .
result data:
dtype (params+1) .
cls statement:
(*CLS *)
next symbol;
apply (1, 0, "nextpage").
data statement:
(*DATA <list of constants> *)
DTYPE VAR const data;
data line (act stat no);
REP IF next data (constant, const data)
THEN data (constant, const data)
ELSE basic error (2, "EOL", "Daten fehlen !") FI;
next symbol;
IF symb.type = eos
THEN LEAVE data statement
ELIF symb.type <> del OR symb.no <> comma
THEN basic error (2, NAME symb, " , erwartet") FI
PER .
def statement: (* DEF/mo *)
(*DEF FN<name> [(parameter list)] = <function definition> *)
get function name;
store label of function;
get all params;
get function definition.
get function name:
next symbol;
IF symb.type <> user fn
THEN treat wrong function name
ELIF LENGTH symb.name <= 2
THEN basic error (2, symb.name, "Unerlaubter Funktionsname")
ELIF known (symb.no)
THEN basic warning ("Die Funktion """ + symb.name + """ wurde bereits definiert");
was warning := TRUE
FI;
SYMBOL VAR function :: symb;
function.name := name of (function.no).
treat wrong function name:
IF symb.type = var OR symb.type = array
THEN basic error (2, symb.name, "Funktionsname muß mit FN beginnen")
ELSE basic error (2, NAME symb, "Funktionsname erwartet")
FI.
store label of function:
IF last label no < label list size
THEN last label no INCR 1
ELSE errorstop ("Zu viele Label")
FI;
declare (label list [last label no]);
TEXT VAR dim text :: "";
dim text CAT last label no;
recognize (function.no, user fn, niladr, function.data, dim text).
get all params:
set scope (function.name + "?");
next symbol;
IF symb.type = del AND symb.no = open bracket
THEN REP
try to get a param;
try to get del
UNTIL symb.no = close bracket OR
(symb.type <> del AND symb.type <> var) PER;
skip close bracket
FI.
try to get a param:
REP
IF symb.type <> var
THEN next symbol
FI;
IF symb.type <> var
THEN careful error (2, NAME symb, "Parametervariable erwartet");
IF symb.type <> del
THEN next symbol
FI
ELSE treat param
FI
UNTIL symb.type <> del OR symb.no = close bracket PER.
treat param:
IF NOT known (symb.no)
THEN declare var (symb, nil);
ELIF already appeared in param list
THEN careful error (89, symb.name, "");
FI;
dim text CAT symb.no.
already appeared in param list:
INT VAR param counter;
FOR param counter FROM 2 UPTO LENGTH dim text DIV 2 REP
IF (dim text ISUB param counter) = symb.no
THEN LEAVE already appeared in param list WITH TRUE
FI
PER;
FALSE.
try to get del:
IF symb.type = var
THEN next symbol
FI;
IF symb.type = var OR (symb.type = del CAND (symb.no <> comma AND symb.no <> close bracket))
THEN careful error (2, symb.name, " , in Parameterliste erwartet")
FI.
skip close bracket:
IF symb.type = del AND symb.no = close bracket
THEN next symbol
ELSE careful error (2, NAME symb, " ) nach Parameterliste erwartet")
FI.
get function definition:
scope compulsory (FALSE);
skip (equal, operator);
generate forward jump;
define this label;
get expr (expr result, function.data);
recognize (function.no, user fn, expr result.adr, function.data, dim text);
goret;
define (behind);
scope compulsory (TRUE);
set scope ("").
generate forward jump:
LABEL VAR behind;
declare (behind);
apply (behind).
define this label:
define (label list [last label no]).
def type statement:
(*DEFINT/DBL/SNG/STR <range(s) of letters> *)
deftype := symb.no;
next symbol;
REP get letter (begin range);
IF symb.type = operator AND symb.no = minus
THEN next symbol;
get letter (end range)
ELSE end range := begin range FI;
IF name of (begin range.no) > name of (end range.no)
THEN basic error (87, begin range.name + "-" + end range.name, "")
ELSE define chars (name of (begin range.no), name of (end range.no), data type) FI;
IF symb.type = eos
THEN LEAVE def type statement
ELSE skip (comma, del) FI
PER .
data type:
SELECT deftype OF
CASE defint s: int type
CASE defstr s: text type
OTHERWISE real type ENDSELECT .
dim statement:
(*DIM <list of subscripted var results> *)
next symbol;
REP get field var;
get field size;
declare field;
IF symb.type = eos
THEN LEAVE dim statement
ELSE skip (comma, del) FI
PER .
get field var:
IF symb.type = array
THEN IF known (symb.no)
THEN basic error (10, symb.name, "")
ELSE field := symb;
next symbol
FI
ELIF symb.type = var
THEN basic error (2, symb.name, "Dimensionsangabe fehlt")
ELSE basic error (2, NAME symb, "Feldname erwartet")
FI.
get field size:
field size := "";
field elems := 1;
skip (open bracket, del);
REP get const (size, int type);
INT CONST field limit :: size.name ISUB 1;
IF field limit < array base
THEN basic error (88, NAME size, "Die Obergrenze muß >= " +
text (array base) + " sein")
ELSE field size CAT (mki (field limit));
field elems := field elems * (field limit + 1 - array base)
FI;
IF symb.type = del AND symb.no = close bracket
THEN next symbol;
LEAVE get field size
ELSE skip (comma, del) FI
PER .
declare field:
field size CAT mki (array base);
field size CAT mki (field elems);
declare var (field, field size) .
end statement:
(*END *)
next symbol;
parameter (1, void type, const, nil adr);
apply (1, 0, ret) .
error statement:
(*ERROR <integer expr result> *)
next symbol;
get expr (expr result, int type);
parameter (1, int type, const, expr result.adr);
parameter (2, text type, const, niltext value);
apply (1, 2, "errorstop") .
gosub statement:
(*GOSUB <line number> *)
next symbol;
get const (label, int type);
gosub (this label) .
goto statement :
(*GOTO <line number> *)
next symbol;
get const (label, int type);
apply (this label) .
this label: label list [label pos (label no)] .
label no: label.name ISUB 1 .
input statement:
(*INPUT [;]["Anfrage" ;/,] Variable [, Variable] *)
ROW 100 DTYPE VAR input var data;
INT VAR number input vars;
LABEL VAR input lab;
next symbol;
declare (input lab);
define (input lab);
get semicolon for cr lf;
get question and question mark;
apply (1, 3, "readinput");
get input eof;
get data types of input vars (input var data, number input vars); (* F25/rr *)
check data types of input vars; (* F8/F25/rr *)
apply (1, 0, "inputok");
apply (input lab, FALSE);
assign list of input var . (* F8/F25/rr *)
get semicolon for cr lf:
IF symb.type = del AND symb.no = semicolon
THEN next symbol;
parameter (1, bool type, const, false value)
ELSE parameter (1, bool type, const, true value) FI .
get question and question mark:
IF symb.type = const AND symb.data = text type
THEN get const (question, text type);
parameter (2, text type, const, question.adr);
parameter (3, bool type, const, question mark value);
next symbol
ELSE parameter (2, text type, const, niltext value);
parameter (3, bool type, const, true value); (* F7/rr *)
FI .
question mark value:
IF symb.type = del AND symb.no = semicolon
THEN true value
ELIF symb.type = del AND symb.no = comma
THEN false value
ELSE basic error (2, NAME symb, " ; oder , erwartet"); nil adr FI .
get input eof:
IF symb.type = res word AND symb.no = eof s
THEN next symbol;
get const (label, int type);
apply (1, 0, "inputeof");
apply (this label, TRUE)
FI .
check data types of input vars : (* F8/F25/rr *)
FOR i FROM 1 UPTO number input vars
REP parameter (1, int type, const, input data type);
apply (1, 1, "checkinput");
apply (input lab, FALSE);
PER .
input data type : (* F8/F25/rr *)
IF input var data (i) = int type THEN one value
ELIF input var data (i) = real type THEN two value
ELIF input var data (i) = text type THEN three value
ELSE zero value
FI .
assign list of input var : (* F8/F25/rr *)
REP get var (var result);
parameter (1, var result. data, var, var result. adr);
apply (1, 1, "assigninput");
IF symb.type = del AND symb.no = comma
THEN next symbol
ELSE LEAVE assign list of input var FI
PER .
kill statement:
(*KILL <filename> *)
next symbol;
get expr (filename, text type);
parameter (1, text type, const, filename.adr);
parameter (2, quiet type, const, next local adr (int type));
apply (2, 0, "quiet");
apply (1, 2, "forget") .
let statement:
(*[LET] <var> = <expression> *)
IF symb.type = res word AND symb.no = let s
THEN next symbol FI;
get var (var result);
skip (equal, operator);
get expr (expr result, var result.data);
apply move (var result.adr, expr result.adr, var result.data).
line statement: (* F9/rr *)
(*1. LINE INPUT [;][<"prompt string">;]<string var result> *)
next symbol;
skip (input s, res word);
get semicolon;
get prompt string;
apply (1, 3, "readinput");
assign string var result .
get semicolon:
IF symb.type = del AND symb.no = semicolon
THEN next symbol;
parameter (1, bool type, const, false value)
ELSE parameter (1, bool type, const, true value) FI .
get prompt string:
IF symb.type = const AND symb.data = text type
THEN get const (question, text type);
parameter (2, text type, const, question.adr);
skip (semicolon, del);
ELSE parameter (2, text type, const, niltext value);
FI;
parameter (3, bool type, const, false value) .
assign string var result :
get var (var result, text type);
parameter (1, text type, var, var result.adr);
apply (1, 1, "assigninputline") .
lprint statement:
(*LPRINT (cf. PRINT) *)
apply (1, 0, "switchtoprintoutfile");
print statement;
apply (1, 0, "switchbacktooldsysoutstate").
l set statement:
(*LSET <string var> = <string expression> *)
next symbol;
get var (var result, text type);
skip (equal, operator);
get expr (expr result, text type);
parameter (1, text type, var, var result.adr);
parameter (2, text type, const, expr result.adr);
apply (1, 2, "lset") .
mid statement:
(*MID$ (<string var>, from [,len]) = <string expression> *)
next symbol;
skip (open bracket, del);
get var (var result, text type);
skip (comma, del);
get expr (from, int type);
IF symb.type = del AND symb.no = comma
THEN next symbol;
get expr (len, int type)
ELSE len := nilsymbol FI;
skip (close bracket, del);
skip (equal, operator);
get expr (expr result, text type);
parameter (1, text type, var, var result.adr);
parameter (2, int type, const, from.adr);
parameter (3, text type, const, expr result.adr);
IF len.data = int type
THEN parameter (4, int type, const, one value);
parameter (5, int type, const, len.adr);
parameter (6, text type, var, next local adr (text type));
apply (3, 3, "subtext");
parameter (3, text type, const, local adr);
FI;
apply (1, 3, "replace") .
name statement:
(*NAME <old filename> AS <new filename> *)
next symbol;
get expr (old name, text type);
skip (as s, res word);
get expr (new name, text type);
parameter (1, text type, const, old name.adr);
parameter (2, text type, const, new name.adr);
apply (1, 2, "rename") .
option statement:
(*OPTION BASE 0|1 *)
next symbol;
skip (base s, res word);
get const (base size, int type);
IF new array base > 1
THEN basic error (105, NAME base size, "")
ELSE array base := new array base
FI.
new array base:
base size.name ISUB 1.
randomize statement:
(*RANDOMIZE [<expression>] *)
next symbol;
IF symb.type = eos
THEN apply (1, 0, "initrnd")
ELSE get expr (expr result, real type);
parameter (1, real type, const, expr result.adr);
apply (1, 1, "initrnd")
FI .
read statement:
(*READ <list of var> *)
next symbol;
REP get var (var result);
parameter (1, text type, const, data text);
parameter (2, int type, var, data pos);
parameter (3, var result.data, var, var result.adr);
apply (1, 3, "read");
IF symb.type = eos
THEN LEAVE read statement
ELSE skip (comma, del) FI
PER .
rem statement:
(*REM <remark> *)
next statement;
symb := SYMBOL : ("", eol, eos, LOC 0, void type);
LEAVE get basic line .
restore statement:
(*RESTORE [<line number>] *)
next symbol;
IF symb.type = eos
THEN parameter (1, int type, var, data pos);
parameter (2, int type, const, one value);
parameter (3, void type, const, nil adr);
apply (1, 2, int move);
ELSE get const (label, int type);
parameter (1, text type, const, data text);
parameter (2, int type, var, data pos);
parameter (3, int type, const, label.adr);
apply (1, 3, "restore")
FI .
return statement :
(*RETURN *)
next symbol;
goret .
r set statement:
(*RSET <string var> = <string expression> *)
next symbol;
get var (var result, text type);
skip (equal, operator);
get expr (expr result, text type);
parameter (1, text type, var, var result.adr);
parameter (2, text type, const, expr result.adr);
apply (1, 2, "rset") .
stop statement:
(*STOP *)
next symbol;
expr result := SYMBOL: (nil, any, const, nil adr, int type);
expr result.name CAT act stat no;
declare const (expr result, int type);
parameter (1, int type, const, expr result.adr);
apply (1, 1, "basicstop");
parameter (1, void type, const, nil adr);
apply (1, 0, ret) .
swap statement:
(*SWAP <var>,<var> *)
next symbol;
get var (var result);
parameter (1, var result.data, var, var result.adr);
DTYPE CONST first var result data :: var result.data;
skip (comma, del);
get var (var result);
IF first var result data = var result.data
THEN parameter (2, var result.data, var, var result.adr);
apply (1, 2, "swap")
ELSE basic error (106, var result.name, "gefunden: "
+ dump (first var result data) + ", " + dump (var result.data))
FI.
troff statement:
(*TROFF *)
next symbol;
basic trace := FALSE .
tron statement:
(*TRON *)
next symbol;
basic trace := TRUE .
width statement:
(*WIDTH Größe *)
next symbol;
get expr (expr result, int type);
parameter (1, int type, const, expr result.adr);
apply (1, 1, "width") .
write statement:
(*WRITE [<list of expr results>] *)
next symbol;
IF symb.type = eos
THEN apply (1, 0, "nextline")
ELSE write list of expr results FI .
write list of expr results:
REP get expr (expr result);
parameter (1, expr result.data, const, expr result.adr);
apply (1, 1, "basicwrite");
IF symb.type = eos
THEN apply (1, 0, "nextline");
LEAVE write list of expr results
ELSE skip (comma, del);
parameter (1, text type, const, comma value);
apply (1, 1, "basicout")
FI
PER .
END PROC get basic line;
PROC gen stat no (INT CONST local stat no):
(* Die Zeilennummer wird als Label definiert *)
(* Die Prozedur 'stat no' wird mit der Statementnummer aufgerufen *)
act stat no := local stat no;
define (label list [label pos (act stat no)]);
declare (1, int type);
declare (1, const);
define (1, act stat no);
parameter (2, void type, const, nil adr);
apply (1, 1, ln op);
IF basic trace
THEN expr result := SYMBOL: (nil, any, const, nil adr, int type);
expr result.name CAT act stat no;
declare const (expr result, int type);
parameter (1, int type, const, expr result.adr);
apply (1, 1, trace op)
FI;
next symbol .
END PROC gen stat no;
PROC for statement:
(*FOR <var> = x TO y [STEP z] *)
SYMBOL VAR local var result, init val, limit val, step val;
LABEL VAR start loop, end loop;
INT CONST for stat no := act stat no, (* F29/rr *)
for scan line no := scan line no;
TEXT CONST for symb name := symb.name;
declare (start loop);
declare (end loop);
next symbol;
get loop var;
skip (equal, operator);
get expr (init val, local var result.data);
skip (to s, res word);
get expr (limit val, local var result.data);
get step val;
init loop var;
define (start loop);
gen check of variable;
get statement group (next s);
IF symb.type = eos AND symb.no = -next s
THEN next var statement
ELSE define (end loop);
basic error ("Compiler", 26, for scan line no, for stat no, for symb name, "", TRUE); (* F29/rr *)
FI .
get loop var:
get var (local var result);
IF NOT (local var result.data = int type OR local var result.data = real type)
THEN basic error (2, NAME local var result, "INT oder REAL erwartet, "
+ dump (local var result.data) + " gefunden")
FI .
get step val:
IF symb.type = res word AND symb.no = step s
THEN next symbol;
get expr (step val, local var result.data)
ELIF local var result.data = int type
THEN step val.data := int type;
step val.adr := int one value
ELSE step val.data := real type;
step val.adr := real one value
FI .
init loop var:
IF local var result.data = int type
THEN init int loop
ELSE init real loop FI .
init int loop:
IF limit val.type = var
THEN parameter (1, int type, var, next local adr (int type));
parameter (2, int type, const, limit val.adr);
parameter (3, void type, const, nil adr);
apply (1, 2, int move);
limit val.adr := local adr;
FI;
IF step val.type = var
THEN parameter (1, int type, var, next local adr (int type));
parameter (2, int type, const, step val.adr);
parameter (3, void type, const, nil adr);
apply (1, 2, int move);
step val.adr := local adr;
FI;
IF NOT (init val.no = local var result.no)
THEN parameter (1, int type, var, local var result.adr);
parameter (2, int type, const, init val.adr);
parameter (3, void type, const, nil adr);
apply (1, 2, int move)
FI .
init real loop:
IF limit val.type = var
THEN parameter (1, real type, var, next local adr (real type));
parameter (2, real type, const, limit val.adr);
parameter (3, void type, const, nil adr);
apply (1, 2, real move);
limit val.adr := local adr;
FI;
IF step val.type = var
THEN parameter (1, real type, var, next local adr (real type));
parameter (2, real type, const, step val.adr);
parameter (3, void type, const, nil adr);
apply (1, 2, real move);
step val.adr := local adr;
FI;
IF NOT (init val.no = local var result.no)
THEN parameter (1, real type, var, local var result.adr);
parameter (2, real type, const, init val.adr);
parameter (3, void type, const, nil adr);
apply (1, 2, real move)
FI .
gen check of variable:
parameter (1, local var result.data, const, local var result.adr);
parameter (2, limit val.data, const, limit val.adr);
parameter (3, step val.data, const, step val.adr);
parameter (4, bool type, const, nil adr); apply (4, nop);
(* In der nächsten Coder-Version ist eine PUSH-Angabe nop nicht nötig *)
apply (1, 3, "loopend");
apply (end loop, TRUE) .
next var statement:
(*NEXT [<var>][,<var>...] *)
next symbol;
generate loop end;
IF symb.type <> eos
THEN check next var result FI .
check next var result:
IF symb.no = local var result.no
THEN next symbol;
IF symb.type = del AND symb.no = comma
THEN next for loop FI
ELSE basic error (86, NAME symb, local var result.name + " erwartet") FI .
next for loop:
IF end symbol = next s
THEN symb := SYMBOL:("", -next s, eos, nil adr, void type)
ELSE basic error (1, symb.name, "") (* mo *)
FI.
generate loop end:
parameter (1, local var result.data, var, local var result.adr);
parameter (2, step val.data, const, step val.adr);
parameter (3, void type, const, nil adr);
IF local var result.data = int type
THEN apply (1, 2, int incr)
ELSE apply (1, 2, real incr) FI;
apply (start loop);
define (end loop) .
END PROC for statement;
PROC if statement : (* Änd. 11.08.87, mo *)
(* IF <expression> THEN <statement(s)>|<line number> *)
(* [ELSE <statement(s)>|<line number>] *)
(* IF <expression> GOTO <line number> *)
(* [ELSE <statement(s)>|<line number>] *)
SYMBOL VAR local expr result;
next symbol;
get expr (local expr result, int type);
skip comma if there;
IF symb.type = res word AND (symb.no = then s OR symb.no = goto s)
THEN test expr result;
IF symb.no = goto s
THEN next symbol;
if goto statement
ELIF next symbol is stat no
THEN if goto statement
ELSE if then statement
FI
ELSE basic error (2, NAME symb, "THEN oder GOTO erwartet") FI .
skip comma if there:
IF symb.no = comma AND symb.type = del
THEN next symbol
FI.
test expr result:
parameter (1, int type, const, local expr result.adr);
parameter (2, bool type, var, nil adr); apply (2, nop);
apply (1, 1, test) .
next symbol is stat no:
next symbol;
symb.type = const AND symb.data = int type.
if goto statement:
SYMBOL VAR stat label;
get const (stat label, int type);
expect else if comma found;
IF symb.type = res word AND symb.no = else s
THEN apply (this label, FALSE);
treat else case
ELIF symb.type <> eos OR symb.no <> eol
THEN declare (else label);
apply (this label, FALSE);
apply (else label);
get basic line (else s);
IF symb.type = eos AND symb.no = -else s
THEN else statement
ELSE define (else label)
FI
ELSE apply (this label, FALSE)
FI.
this label: label list [label pos (label no)] .
label no: stat label.name ISUB 1 .
expect else if comma found:
IF symb.type = del AND symb.no = comma
THEN next symbol;
IF symb.no <> else s OR symb.type <> res word
THEN basic error (2, NAME symb, "ELSE erwartet")
FI
FI.
treat else case:
IF next symbol is stat no
THEN get const (stat label, int type);
apply (this label)
ELSE get basic line
FI.
if then statement:
LABEL VAR fi label;
declare (else label);
apply (else label, TRUE);
get basic line (else s);
IF symb.type = eos AND symb.no = -else s
THEN declare (fi label);
apply (fi label);
else statement;
define (fi label)
ELSE define (else label) FI .
else statement:
LABEL VAR else label;
define (else label);
treat else case.
END PROC if statement;
PROC on statement:
(*2. ON <expression> GOSUB <list of line numbers> *)
(*3. ON <expression> GOTO <list of line numbers> *)
LABEL VAR before case, after case, return case;
declare (before case);
declare (after case);
declare (return case);
next symbol;
IF symb.type = res word AND symb.no = error s
THEN basic error (100, symb.name, "")
FI;
get expr (expr result, int type);
IF on gosub statement
THEN gosub (before case);
apply (after case)
ELIF NOT on goto statement
THEN basic error (2, symb.name, "GOTO oder GOSUB erwartet") FI;
get case stat no;
define (before case);
gen case branches;
gen return case;
define (after case) .
on gosub statement:
BOOL CONST gosub found := symb.type = res word AND symb.no = gosub s;
gosub found .
on goto statement:
symb.type = res word AND symb.no = goto s.
get case stat no:
TEXT VAR case stat no :: nil;
INT VAR case no :: 0;
next symbol;
REP get const (label, int type);
case no INCR 1;
case stat no CAT label.name;
IF symb.type = eos
THEN LEAVE get case stat no
ELSE skip (comma, del) FI
PER .
gen case branches:
computedbranch (expr result.adr, case no + 1, otherwise lab); (* F6/rr *)
apply (otherwise lab);
FOR i FROM 1 UPTO case no
REP apply (label i) PER .
gen return case:
IF gosub found
THEN define (return case);
goret
FI .
otherwise lab:
IF gosub found
THEN return case
ELSE after case FI .
label i:
label list [label pos (case stat no ISUB i)] .
END PROC on statement;
PROC print statement:
(*PRINT [<list of expr results>] *)
(*PRINT USING <string exp>;<list of expression> *)
(*PRINT #<file number>,<list of expr results> *)
(*PRINT #<file number>, USING <string exp>;<list of expression> *)
next symbol;
IF symb.type = del AND symb.no = numbersign
THEN print file statement
ELSE print display statement FI .
print file statement:
basic error (100, symb.name, "") .
print display statement:
get format string;
print list of expr results;
reset format string .
get format string:
IF symb.type = res word AND symb.no = using s
THEN next symbol;
get expr (image, text type);
skip (semicolon, del);
parameter (1, text type, const, image.adr);
apply (1, 1, "using");
ELSE image := nilsymbol FI .
reset format string:
IF image.type <> any
THEN apply (1, 0, "clearusing") FI .
print list of expr results:
REP IF symb.type = res word AND symb.no = tab s
THEN get tabulation
ELIF symb.type = del AND symb.no = comma
THEN get next zone
ELIF symb.type = del AND symb.no = semicolon
THEN get next pos
ELIF symb.type = eos
THEN apply (1, 0, "nextline");
LEAVE print list of expr results
ELSE get print expr result FI;
PER .
get tabulation:
next symbol;
skip (open bracket, del);
get expr (tab pos, int type);
skip (close bracket, del);
parameter (1, int type, const, tab pos.adr);
apply (1, 1, "tab") .
get next zone:
next symbol;
IF image.type = any
THEN apply (1, 0, "nextzone") FI;
IF symb.type = eos
THEN LEAVE print list of expr results FI .
get next pos:
next symbol;
IF symb.type = eos
THEN LEAVE print list of expr results FI .
get print expr result:
get expr (expr result);
parameter (1, expr result.data, const, expr result.adr);
apply (1, 1, "basicout") .
END PROC print statement;
PROC while statement:
(*WHILE <expression> *)
LABEL VAR while lab, wend lab;
SYMBOL VAR while expr result;
INT CONST while stat no := act stat no, (* F29/rr *)
while scan line no := scan line no;
TEXT CONST while symb name := symb.name;
next symbol;
declare (while lab);
declare (wend lab);
define (while lab);
get expr (while expr result, int type);
parameter (1, int type, const, while expr result.adr);
parameter (2, bool type, const, nil adr); apply (2, nop);
apply (1, 1, test);
apply (wend lab, TRUE); (* 'test' vergleicht mit 0 *)
get statement group (wend s);
IF symb.type = eos AND symb.no = -wend s
THEN wend statement
ELSE basic error ("Compiler", 29, while scan line no, while stat no, while symb name, "", TRUE) FI. (* F29/rr *)
wend statement:
(*WEND *)
apply (while lab);
define (wend lab);
next symbol .
END PROC while statement;
END PACKET basic compiler