(***************************************************************************) (* *) (* 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 [()] *) 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 *) 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 [(parameter list)] = *) 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 *) 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 *) 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 *) 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 *) next symbol; get const (label, int type); gosub (this label) . goto statement : (*GOTO *) 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 *) 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] = *) 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">;] *) 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 = *) 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$ (, from [,len]) = *) 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 AS *) 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 [] *) 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 *) 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 *) next statement; symb := SYMBOL : ("", eol, eos, LOC 0, void type); LEAVE get basic line . restore statement: (*RESTORE [] *) 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 = *) 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 , *) 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 [] *) 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 = 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 [][,...] *) 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 THEN | *) (* [ELSE |] *) (* IF GOTO *) (* [ELSE |] *) 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 GOSUB *) (*3. ON GOTO *) 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 [] *) (*PRINT USING ; *) (*PRINT #, *) (*PRINT #, USING ; *) 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 *) 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