summaryrefslogtreecommitdiff
path: root/lang/basic/1.8.7/src
diff options
context:
space:
mode:
Diffstat (limited to 'lang/basic/1.8.7/src')
-rw-r--r--lang/basic/1.8.7/src/BASIC.Administration1886
-rw-r--r--lang/basic/1.8.7/src/BASIC.Compiler2305
-rw-r--r--lang/basic/1.8.7/src/BASIC.Runtime1571
l---------lang/basic/1.8.7/src/eumel coder 1.8.11
-rw-r--r--lang/basic/1.8.7/src/eumel0 codesbin0 -> 512 bytes
-rw-r--r--lang/basic/1.8.7/src/gen.BASIC80
6 files changed, 5843 insertions, 0 deletions
diff --git a/lang/basic/1.8.7/src/BASIC.Administration b/lang/basic/1.8.7/src/BASIC.Administration
new file mode 100644
index 0000000..6df6854
--- /dev/null
+++ b/lang/basic/1.8.7/src/BASIC.Administration
@@ -0,0 +1,1886 @@
+(***************************************************************************)
+(* *)
+(* Zweite von drei Dateien des EUMEL-BASIC-Systems *)
+(* *)
+(* Autor: Heiko Indenbirken *)
+(* Überarbeitet von: Rudolf Ruland und Michael Overdick *)
+(* *)
+(* Stand: 27.10.1987 *)
+(* *)
+(***************************************************************************)
+
+PACKET basic errors DEFINES basic error, (* Autor: Heiko Indenbirken *)
+ return error, (* Stand: 26.08.1987/rr/mo *)
+ basic warning:
+
+TEXT VAR erste zeile,
+ message;
+LET errorsize = 40;
+LET ERROR = STRUCT (INT no, TEXT msg);
+
+ROW errorsize ERROR CONST error msg :: ROW errorsize ERROR :
+(ERROR:( 1, "NEXT ohne FOR"),
+ ERROR:( 2, "Syntaxfehler:"),
+ ERROR:( 5, "Fehlerhafter Funktionsaufruf"),
+ ERROR:( 8, "Zeile mit dieser Nummer existiert nicht"),
+ ERROR:(10, "Das Feld ist bereits dimensioniert"),
+ ERROR:(13, "Falscher Typ:"),
+ ERROR:(15, "Text zu lang"),
+ ERROR:(18, "Undefinierte 'user function'"),
+ ERROR:(22, "Ausdruck erwartet"),
+ ERROR:(26, "FOR ohne NEXT"),
+ ERROR:(29, "WHILE ohne WEND"),
+ ERROR:(30, "WEND ohne WHILE"),
+ ERROR:(51, "Interner Fehler"),
+ ERROR:(80, "Fehlerhafte Zeilennummer"),
+ ERROR:(81, "Falsche Reihenfolge der Zeilennummern"),
+ ERROR:(82, "Falscher Typ des Operanden:"),
+ ERROR:(83, "Falscher Typ der Operanden:"),
+ ERROR:(84, "Falsche Felddimension:"),
+ ERROR:(85, "Rekursive Funktionsdefinition"),
+ ERROR:(86, "Fehlerhafte Laufvariable:"),
+ ERROR:(87, "Fehlerhafte Bereichsangabe:"),
+ ERROR:(88, "Fehlerhafte Dimensionierung:"),
+ ERROR:(89, "Parametervariable kommt mehrmals vor"),
+ ERROR:(90, "AS ohne NAME"),
+ ERROR:(91, "BASE ohne OPTION"),
+ ERROR:(92, "ELSE ohne IF"),
+ ERROR:(93, "STEP ohne FOR"),
+ ERROR:(94, "TAB ohne (L)PRINT"),
+ ERROR:(95, "THEN ohne IF"),
+ ERROR:(96, "TO ohne Zusammenhang"),
+ ERROR:(97, "USING ohne (L)PRINT"),
+ ERROR:(98, "Unbekannte Funktion,"),
+ ERROR:(99, "Unbekannte Prozedur,"),
+ ERROR:(100,"Nicht implementiert"),
+ ERROR:(101,"SUB ohne GO"),
+ ERROR:(102,"GO ohne TO oder SUB"),
+ ERROR:(103,"Accessrecht VAR erwartet, CONST gefunden"),
+ ERROR:(104,"Funktionsaufruf ohne Zusammenhang"),
+ ERROR:(105,"Nach OPTION BASE ist nur 0 oder 1 erlaubt"),
+ ERROR:(106,"Bei SWAP nur gleiche Variablentypen erlaubt"));
+
+TEXT PROC errortext (INT CONST no):
+ INT VAR i;
+ FOR i FROM 1 UPTO errorsize
+ REP IF errormsg [i].no = no
+ THEN LEAVE errortext WITH errormsg [i].msg FI
+ PER;
+ "Unbekannter BASIC-Fehler #" + text (no) .
+END PROC errortext;
+
+PROC basic error (TEXT CONST packet,
+ INT CONST error nr,
+ INT CONST line nr,
+ INT CONST statement nr,
+ TEXT CONST position, addition,
+ BOOL CONST leave statement):
+ erste zeile aufbauen;
+ einfache fehlermeldung aufbauen;
+ diese auf terminal ausgeben;
+ diese in sysout datei ausgeben wenn noetig; (* F20/rr *)
+ fehlermeldung in fehlerdatei ausgeben;
+ IF leave statement (* DEF/mo *)
+ THEN errorstop (101, packet + "-Fehler")
+ FI.
+
+erste zeile aufbauen:
+ IF line nr = 0 AND statement nr = 0
+ THEN erste zeile := "FEHLER"
+ ELSE erste zeile := "FEHLER (Dateizeile ";
+ erste zeile CAT text (line nr);
+ erste zeile CAT ") in Zeile ";
+ erste zeile CAT text (statement nr);
+ FI;
+
+ erste zeile CAT " bei >> ";
+ erste zeile CAT position;
+ erste zeile CAT " << : " .
+
+einfache fehlermeldung aufbauen:
+ message := " ";
+ message CAT error text (error nr);
+ message CAT " " .
+
+diese auf terminal ausgeben: (* F20/rr *)
+ display (""13""10"");
+ display (erste zeile);
+ display (""13""10"");
+ display (message + addition);
+ display (""13""10"") .
+
+diese in sysout datei ausgeben wenn noetig : (* F20/rr *)
+ IF sysout <> ""
+ THEN putline (erste zeile);
+ putline (message + addition);
+ line;
+ FI .
+
+fehlermeldung in fehlerdatei ausgeben:
+ note (erste zeile);
+ note line;
+ note (message);
+ note (addition);
+ note line .
+
+END PROC basic error;
+
+PROC basic warning (INT CONST line nr, (* mo *)
+ statement nr,
+ TEXT CONST warning text):
+generate warning;
+on screen;
+in sysout file;
+into the notebook.
+
+generate warning:
+ IF line nr = 0 AND statement nr = 0
+ THEN erste zeile := "WARNUNG"
+ ELSE erste zeile := "WARNUNG (Dateizeile ";
+ erste zeile CAT text (line nr);
+ erste zeile CAT ") in Zeile ";
+ erste zeile CAT text (statement nr);
+ FI;
+ erste zeile CAT ": ";
+ erste zeile CAT warning text.
+
+on screen:
+ display (""13""10"");
+ display (erste zeile);
+ display (""13""10"").
+
+in sysout file:
+ IF sysout <> ""
+ THEN putline (erste zeile);
+ line;
+ FI.
+
+into the notebook:
+ IF warnings
+ THEN note (erste zeile);
+ note line
+ FI.
+
+END PROC basic warning;
+
+PROC return error:
+ errorstop (1003, "RETURN ohne GOSUB")
+END PROC return error;
+
+END PACKET basic errors;
+
+PACKET basic types DEFINES symbol of, (* Autor: Heiko Indenbirken *)
+ type of, (* Stand: 07.09.1987/rr/mo *)
+ dim of,
+ shift, deshift,
+ reserved,
+ param list,
+ is bool op:
+
+LET (* S y m b o l T y p e n *)
+ any = 0, const = 1, var = 2, array = 3,
+ expr = 4, unused = 5, letter = 6, param = 7,
+ res word = 8, operator = 9, eos = 10, del = 11,
+ stat no = 12, eol = 13, eop = 14,
+ user fn = 20; (* DEF/mo *)
+(* Operatoren *)
+LET less equal = 28, unequal = 29, greater equal = 30;
+
+TEXT VAR dummy;
+
+TEXT PROC symbol of (INT CONST n) :
+ IF n < 0
+ THEN ""19"" + symbol of (-n)
+ ELSE SELECT n OF
+ CASE less equal : "<="
+ CASE unequal : "<>"
+ CASE greater equal : ">="
+
+ CASE eos : "EOS"
+ CASE eol : "EOL"
+ CASE eop : "EOF"
+ OTHERWISE : character END SELECT
+ FI .
+
+character :
+ IF n > 32 AND n < 128
+ THEN code (n)
+ ELIF n >= 128 AND n <= 255
+ THEN res word of (n)
+ ELSE "%" + subtext (text (n+1000), 2) + " " FI .
+
+END PROC symbol of;
+
+TEXT PROC type of (INT CONST n) :
+ SELECT n OF
+ CASE any : "ANY"
+ CASE const : "Konstante"
+ CASE var : "Variable"
+ CASE array : "Feld"
+ CASE expr : "Ausdruck"
+ CASE unused : " -?- "
+ CASE letter : "Buchstabe"
+ CASE param : "Parameter"
+ CASE res word : "reserviertes Wort"
+ CASE operator : "Operator"
+ CASE eos : "EOS"
+ CASE del : "Trennzeichen"
+ CASE stat no : "Zeilennumer"
+ CASE eol : "EOL"
+ CASE eop : "EOF"
+ CASE user fn : "'user function'" (* DEF/mo *)
+ OTHERWISE "?TYPE #" + text (n) ENDSELECT.
+END PROC type of;
+
+TEXT PROC dim of (TEXT CONST parameter):
+ IF parameter = ""
+ THEN ""
+ ELSE base limits and size FI .
+
+base limits and size:
+ INT CONST dimension :: (LENGTH parameter DIV 2) - 2;
+ TEXT VAR result :: text (parameter ISUB dimension+1);
+ INT VAR i;
+ result CAT ": [";
+ FOR i FROM 1 UPTO dimension-1
+ REP result CAT text (parameter ISUB i);
+ result CAT ", "
+ PER;
+ result CAT text (parameter ISUB dimension);
+ result CAT "] ";
+ result CAT text (parameter ISUB dimension+2);
+ result .
+
+END PROC dim of;
+
+TEXT PROC param list (INT CONST first, no):
+ IF no < first
+ THEN "keine"
+ ELSE parameter list FI .
+
+parameter list:
+ INT VAR i;
+ TEXT VAR result :: "(";
+ FOR i FROM first UPTO no
+ REP result CAT dump (dtype (i));
+ IF i = no
+ THEN result CAT ")"
+ ELSE result CAT ", " FI
+ PER;
+ result .
+
+END PROC param list;
+
+TEXT PROC shift (TEXT CONST word) :
+ INT VAR i;
+ dummy := word;
+ FOR i FROM 1 UPTO length (word)
+ REP shift char PER;
+ dummy .
+
+shift char:
+ INT VAR local letter :: code (dummy SUB i);
+ IF 97 <= local letter AND local letter <= 122
+ THEN replace (dummy, i, code (local letter - 32)) FI .
+
+END PROC shift;
+
+TEXT PROC deshift (TEXT CONST word) :
+ INT VAR i;
+ dummy := word;
+ FOR i FROM 1 UPTO length (word)
+ REP deshift char PER;
+ dummy .
+
+deshift char:
+ INT VAR local letter :: code (dummy SUB i);
+ IF 65 <= local letter AND local letter <= 90
+ THEN replace (dummy, i, code (local letter + 32)) FI;
+
+END PROC deshift;
+
+(* Verwaltung der Reservierten BASIC-Wörter *)
+LET first operator = 249, (* MOD NOT AND OR XOR EQV IMP *)
+ first bool op = 250; (* 249 250 251 252 253 254 255 *)
+
+INT VAR index;
+ROW 9 TEXT VAR res words :: ROW 9 TEXT :
+("",
+ ""129"as"163"go"167"if"188"on"217"to"252"or",
+ ""128"abs"130"asc"131"atn"141"cos"142"cvd"143"cvi"145"def"150"dim"152"end"153"eof"154"erl"155"err"157"exp"159"fix"160"for"161"fre"162"get"172"int"175"len"176"let"178"loc"179"log"191"out"192"pos"194"put"202"rnd"197"rem"204"sgn"205"sin"207"spc"208"sqr"214"tab"215"tan"221"val"227"cls"234"usr"235"sub"249"mod"250"not"251"and"253"xor"254"eqv"255"imp",
+ ""132"base"133"call"134"cdbl"136"chr$"137"cint"144"data"151"else"165"goto"166"hex$"173"kill"177"line"181"lset"182"mid$"183"mkd$"184"mki$"185"name"186"next"187"oct$"189"open"196"read"203"rset"209"step"210"stop"211"str$"213"swap"216"then"219"tron"222"wait"223"wend"228"erm$"230"lpos",
+ ""135"chain"138"clear"139"close"156"error"158"field"164"gosub"169"input"171"instr"174"left$"193"print"218"troff"220"using"224"while"225"width"226"write"231"time$"232"date$"233"timer",
+ ""140"common"146"defdbl"147"defint"148"defsng"149"defstr"168"inkey$"170"input$"180"lprint"190"option"199"resume"200"return"201"right$"206"space$"229"csrlin",
+ ""198"restore"212"string$",
+ "",
+ ""195"randomize");
+
+BOOL PROC reserved (TEXT CONST name, INT VAR no, type):
+ IF reserve is not possible COR not found within res words
+ THEN FALSE
+ ELSE no := code (this words SUB (index-1));
+ type := res word or op;
+ TRUE
+ FI .
+
+reserve is not possible:
+ INT CONST len :: length (name);
+ len < 2 OR len > 9 .
+
+not found within res words:
+ index := pos (this words, name);
+ index = 0 .
+
+this words:
+ res words [len] .
+
+res word or op:
+ IF no >= first operator
+ THEN operator
+ ELSE res word FI .
+
+END PROC reserved;
+
+INT PROC reserved (TEXT CONST name):
+ IF reserve is not possible COR not found within res words
+ THEN 0
+ ELSE code (this words SUB (index-1)) FI .
+
+reserve is not possible:
+ INT CONST len :: length (name);
+ len < 2 OR len > 9 .
+
+not found within res words:
+ index := pos (this words, name);
+ index = 0 .
+
+this words:
+ res words [len] .
+
+END PROC reserved;
+
+TEXT PROC res word of (INT CONST no):
+ INT VAR i;
+ FOR i FROM 2 UPTO 9
+ REP index := pos (res words [i], code (no));
+ IF index > 0
+ THEN LEAVE res word of WITH shift (this name) FI
+ PER;
+ "" .
+
+this name:
+ subtext (res words [i], index+1, next code) .
+
+next code:
+ INT VAR c := pos (res words [i], ""127"", ""255"", index+1);
+ IF c = 0
+ THEN length (res words [i])
+ ELSE c-1 FI .
+
+END PROC res word of;
+
+BOOL PROC is bool op (INT CONST no): (* mo *)
+ no >= first bool op
+END PROC is bool op;
+
+END PACKET basic types;
+
+PACKET basic table handling DEFINES init table, (* Autor: Heiko Indenbirken *)
+ put name, (* Stand: 13.08.1987/rr/mo *)
+ known, name of,
+ remember,
+ recognize,
+ table entries,
+ hash table, next table,
+ scope compulsory: (* DEF/mo *)
+
+LET hash length = 1024,
+ hash length minus one = 1023,
+ start of name table = 256,
+ table length = 4500;
+
+LET SYMBOL = STRUCT (INT type, ADDRESS adr, DTYPE data, TEXT dim);
+LET TABLE = STRUCT (INT entries,
+ ROW hash length INT hash table,
+ ROW table length INT next,
+ ROW table length TEXT name table,
+ ROW table length SYMBOL symbol table);
+
+DATASPACE VAR table space;
+BOUND TABLE VAR table;
+INITFLAG VAR tab := FALSE;
+SYMBOL CONST nilsymbol :: SYMBOL:(0, LOC 0, void type, "");
+INT VAR i;
+BOOL VAR compulsory with scope :: TRUE; (* DEF/mo *)
+
+PROC init table:
+ IF NOT initialized (tab)
+ THEN table space := nilspace;
+ table := table space;
+ FI;
+ table.entries := start of name table;
+ FOR i FROM 1 UPTO hash length
+ REP table.hash table [i] := 0 PER;
+ compulsory with scope := TRUE; (* DEF/mo *)
+
+END PROC init table;
+
+PROC put name (TEXT CONST scope, name, INT VAR pointer): (* DEF/mo *)
+ IF compulsory with scope
+ THEN put name (scope + name, pointer)
+ ELIF NOT in table
+ THEN put name (name, pointer)
+ FI.
+
+in table:
+ hash (scope + name, pointer);
+ pointer := hash table (pointer);
+ WHILE not end of chain
+ REP IF name is found THEN LEAVE in table WITH TRUE FI;
+ pointer := table. next (pointer);
+ PER;
+ FALSE .
+
+name is found:
+ table.name table [pointer] = scope + name.
+
+not end of chain:
+ pointer > 0 .
+
+END PROC put name;
+
+PROC put name (TEXT CONST name, INT VAR pointer):
+ IF no entry in hash table
+ THEN create a new chain
+ ELSE create a new entry in chain FI;
+ insert name in name table .
+
+no entry in hash table:
+ INT VAR hash index;
+ hash (name, hash index);
+ table.hash table [hash index] = 0 .
+
+create a new chain:
+ table.hash table [hash index] := table.entries .
+
+create a new entry in chain:
+ pointer := table.hash table [hash index];
+ REP IF name is found
+ THEN LEAVE put name
+ ELIF end of chain
+ THEN table.next [pointer] := table.entries;
+ LEAVE create a new entry in chain
+ ELSE pointer := next pointer FI
+ PER .
+
+name is found:
+ table.name table [pointer] = name.
+
+end of chain:
+ INT CONST next pointer := table.next [pointer];
+ next pointer = 0 .
+
+insert name in name table:
+ IF table.entries >= table length
+ THEN errorstop ("volle Namenstabelle") FI;
+
+ pointer := table.entries;
+ table.symbol table [pointer] := nilsymbol;
+ table.name table [pointer] := name;
+ table.next [pointer] := 0;
+ table.entries INCR 1 .
+
+END PROC put name;
+
+PROC hash (TEXT CONST name, INT VAR index) :
+ INT VAR j;
+ index := 0;
+ FOR j FROM 1 UPTO length (name)
+ REP addmult cyclic PER;
+ index INCR 1 .
+
+addmult cyclic :
+ index INCR index ;
+ IF index > hash length minus one
+ THEN wrap around FI;
+ index := (index + code (name SUB j)) MOD hash length minus one .
+
+wrap around:
+ index DECR hash length minus one .
+
+ENDPROC hash ;
+
+INT PROC table entries:
+ table.entries
+END PROC table entries;
+
+INT PROC hash table (INT CONST n):
+ table.hash table [n]
+END PROC hash table;
+
+INT PROC next table (INT CONST n):
+ table.next [n]
+END PROC next table;
+
+TEXT PROC name of (INT CONST index):
+ IF index < 0
+ THEN errorstop ("PROC name of: negativer Index"); ""
+ ELIF index < start of name table
+ THEN symbol of (index)
+ ELIF index <= table.entries
+ THEN table.name table (index)
+ ELSE errorstop ("PROC name of: Index größer als nametable");
+ ""
+ FI
+
+END PROC name of;
+
+PROC recognize (INT CONST symb, type, ADDRESS CONST adr, DTYPE CONST data, TEXT CONST dim):
+ symbol.type := type;
+ symbol.adr := adr;
+ symbol.data := data;
+ symbol.dim := dim .
+
+symbol: table.symboltable [symb] .
+END PROC recognize;
+
+PROC remember (INT CONST symb, INT VAR type, ADDRESS VAR adr, DTYPE VAR data, TEXT VAR dim):
+ SYMBOL CONST symbol := table.symboltable [symb];
+ type := symbol.type;
+ adr := symbol.adr;
+ data := symbol.data;
+ dim := symbol.dim
+END PROC remember;
+
+BOOL PROC known (INT CONST symb) :
+ table.symboltable [symb].type > 0
+END PROC known;
+
+PROC scope compulsory (BOOL CONST new state): (* DEF/mo *)
+ compulsory with scope := new state
+END PROC scope compulsory;
+
+END PACKET basic table handling;
+
+PACKET basic scanner DEFINES begin scanning, (* Autor: Heiko Indenbirken *)
+ next symbol, (* Stand: 27.10.1987/rr/mo *)
+ next data,
+ next statement,
+ define chars,
+ scan line,
+ scan line no, (* F29/rr *)
+ get data types of input vars, (* F25/rr *)
+ basic error,
+ basic warning,
+ basic list,
+ set scope,
+ scanner scope:
+
+
+LET (* S y m b o l T y p e n *)
+ any = 0, const = 1, var = 2, array = 3,
+ res word= 8, operator= 9, eos = 10, del =11,
+ stat no = 12, user fn = 20; (* DEF/mo *)
+
+LET (* S y m b o l z e i c h e n *)
+ less = 60, greater = 62,
+ less equal = 28, unequal = 29, greater equal = 30,
+ point = 46, eol = 13, eop = 14,
+ go = 163, gosub = 164, goto = 165,
+ sub = 235, to = 217;
+
+LET name chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz.0123456789!#$%",
+ quote = """", open bracket = "(",
+ comma = ",", close bracket = ")",
+ colon = ":",
+ exponent chars= "dDeE";
+
+FILE VAR source file;
+TEXT VAR defint chars, defstr chars, record, letter,
+ scope, new name; (* DEF/mo *)
+REAL VAR r dummy;
+INT VAR act stat no, record no, rec len, scan pos, i dummy;
+BOOL VAR eol generated, at line begin, listing := FALSE;
+
+PROC define chars (TEXT CONST begin, end, DTYPE CONST data):
+ INT VAR i;
+ FOR i FROM code (begin) UPTO code (end)
+ REP IF data = int type
+ THEN defint chars CAT code (i)
+ ELIF data = text type
+ THEN defstr chars CAT code (i)
+ FI
+ PER .
+
+END PROC define chars;
+
+
+PROC scanline (TEXT VAR line, INT VAR col):
+ line := record;
+ col := scan pos
+END PROC scanline;
+
+INT PROC scan line no : record no END PROC scan line no;
+
+
+PROC get data types of input vars (ROW 100 DTYPE VAR input var data, (* F25/rr *)
+ INT VAR number input vars) :
+
+ TEXT VAR first var char;
+ INT VAR var pos := scan pos;
+ to begin of actual var;
+ REP get next input var;
+ skip brackets if necessary;
+ IF var char <> comma THEN LEAVE get data types of input vars FI;
+ skip comma;
+ PER;
+
+ . var char : record SUB var pos
+
+ . to begin of actual var :
+ WHILE pos (name chars, var char) <> 0 REP var pos DECR 1 PER;
+ var pos INCR 1;
+ number input vars := 0;
+
+ . get next input var :
+ first var char := deshift (var char);
+ WHILE pos (name chars, var char) <> 0 REP var pos INCR 1 PER;
+ var pos DECR 1;
+ number input vars INCR 1;
+ input var data (number input vars) := var datatype (first var char, var char);
+ var pos := pos (record, ""33"", ""255"", var pos + 1);
+
+ . skip brackets if necessary :
+ IF var char = open bracket
+ THEN INT VAR bracket counter := 1;
+ REP count bracket UNTIL bracket counter = 0 PER;
+ var pos := pos (record, ""33"", ""255"", var pos + 1);
+ FI;
+
+ . count bracket :
+ INT CONST open := pos (record, open bracket, var pos + 1),
+ close := pos (record, close bracket, var pos + 1);
+ IF open > 0
+ THEN IF close > 0
+ THEN IF open > close
+ THEN close bracket found
+ ELSE open bracket found
+ FI;
+ ELSE open bracket found
+ FI;
+ ELSE IF close > 0
+ THEN close bracket found
+ ELSE LEAVE get data types of input vars
+ FI;
+ FI;
+
+ . open bracket found :
+ bracket counter INCR 1;
+ var pos := open;
+
+ . close bracket found :
+ bracket counter DECR 1;
+ var pos := close;
+
+ . skip comma :
+ var pos := pos (record, ""33"", ""255"", var pos + 1);
+
+END PROC get data types of input vars;
+
+
+PROC begin scanning (FILE VAR basic file):
+ enable stop;
+ source file := basic file;
+ to first record (source file);
+ col (source file, 1);
+ IF eof (source file)
+ THEN errorstop ("Datei ist leer") FI;
+
+ defint chars := "";
+ defstr chars := "";
+ scope := ""; (* DEF/mo *)
+ act stat no := 0;
+ read record (source file, record);
+ rec len := length (record);
+ scan pos := 0;
+ record no := 1;
+ eol generated := FALSE;
+ at line begin := TRUE;
+ IF listing
+ THEN line;
+ putline (record);
+ IF sysout <> ""
+ THEN cout (record no)
+ FI
+ ELSE cout (record no)
+ FI.
+
+END PROC begin scanning;
+
+PROC next statement:
+ IF eof (source file)
+ THEN errorstop (99, "")
+ ELSE eol generated := FALSE;
+ at line begin := TRUE;
+ down (source file);
+ read record (source file, record);
+ rec len := length (record);
+ scan pos := 0;
+ record no INCR 1;
+ FI;
+ IF listing
+ THEN putline (record);
+ IF sysout <> ""
+ THEN cout (record no)
+ FI
+ ELSE cout (record no)
+ FI.
+
+END PROC next statement;
+
+PROC next symbol (TEXT VAR name, INT VAR no, type, DTYPE VAR data):
+ enable stop;
+ clear symbol;
+ IF eol generated
+ THEN next statement FI;
+
+ IF eol reached
+ THEN generate eol
+ ELIF at line begin CAND stat no found (* F15/rr *)
+ THEN generate stat no
+ ELSE generate chars FI .
+
+clear symbol:
+ name := "";
+ no := 0;
+ type := any;
+ data := void type .
+
+eol reached:
+ scan pos := pos (record, ""33"", ""255"", scan pos+1);
+ scan pos = 0 .
+
+generate eol :
+ IF eof (source file)
+ THEN name := "EOF"; no := eop; type := eos
+ ELSE name := "EOL"; no := eol; type := eos FI;
+ eol generated := TRUE .
+
+stat no found: (* F15/rr *)
+ at line begin := FALSE;
+ pos ("0123456789", act char) <> 0 .
+
+generate stat no: (* F15/rr *)
+ INT CONST next scan pos := last number pos;
+ name := subtext (record, scan pos, next scan pos);
+ act stat no := int (name);
+ scan pos := next scan pos;
+ no := act stat no; type := stat no .
+
+last number pos : (* F15/rr *)
+ INT CONST high := pos (record, ""058"", ""255"", scan pos),
+ low := pos (record, ""032"", ""047"", scan pos);
+ IF high > 0
+ THEN IF low > 0
+ THEN min (high, low) - 1
+ ELSE high - 1
+ FI
+ ELIF low > 0
+ THEN low - 1
+ ELSE LENGTH record
+ FI .
+
+generate chars:
+ SELECT code (act char) OF
+ CASE 32: next symbol (name, no, type, data) (* Space *)
+ CASE 34: generate text denoter (* " *)
+ CASE 39: generate eol (* ' *)
+ CASE 42, 43, 45, 47, 92, 94, 61: generate operator (* *,+,-,/,\,^,=*)
+ CASE 60: generate less op (*<, <=, <> *)
+ CASE 62: generate greater op (*>, >= *)
+ CASE 46: treat point (* . *)
+ CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57:
+ generate numeric const (* 0 - 9 *)
+ CASE 58: generate eos (* : *)
+ CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 90, 97, 98, 99, 100, 101, 102, 103,
+ 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117,
+ 118, 119, 120, 121, 122, (* small and large letters *)
+ generate res word or id
+ OTHERWISE generate delimiter END SELECT .
+
+generate text denoter:
+ get text const (name, data);
+ type := const .
+
+generate operator:
+ name := act char; no := code (name); type := operator .
+
+generate less op:
+ IF next char = "="
+ THEN name := "<="; no := less equal; skip char
+ ELIF next char = ">"
+ THEN name := "<>"; no := unequal; skip char
+ ELSE name := "<"; no := less FI;
+ type := operator .
+
+generate greater op:
+ IF next char = "="
+ THEN name := ">="; no := greater equal; skip char
+ ELSE name := ">"; no := greater; FI;
+ type := operator .
+
+treat point:
+ IF pos ("0123456789", next char) <> 0
+ THEN generate numeric const
+ ELSE name := ".";
+ no := point;
+ type := del
+ FI.
+
+generate numeric const:
+ get numeric const (name, data);
+ type := const .
+
+last name char:
+ name SUB LENGTH name .
+
+generate eos:
+ name := ":"; no := eos; type := eos .
+
+generate res word or id:
+ get name chars;
+ IF reserved (deshift name, no, type)
+ THEN IF type = res word AND no = go
+ THEN treat go
+ FI
+ ELSE IF function name
+ THEN data := ftn datatype;
+ type := user fn
+ ELSE data := var datatype (deshift (name) SUB 1, last name char);
+ type := var or array
+ FI;
+ put name (scope, deshift name, no)
+ FI.
+
+treat go:
+ next symbol (new name, no, type, data);
+ IF no = to AND type = res word
+ THEN name CAT new name;
+ no := goto
+ ELIF no = sub AND type = res word
+ THEN name CAT new name;
+ no := gosub
+ ELSE scan error (102, name, "")
+ FI.
+
+get name chars:
+ TEXT VAR deshift name :: "";
+ INT VAR begin of name :: scan pos;
+ FOR scan pos FROM scan pos UPTO rec len
+ WHILE name chars found
+ REP deshift name CAT deshifted char PER;
+ scan pos DECR 1;
+ name := subtext (record, begin of name, scan pos).
+
+name chars found:
+ pos (name chars, act char) > 0 .
+
+function name:
+ subtext (deshift name, 1, 2) = "fn" .
+
+ftn datatype:
+ IF last name char = "$"
+ THEN text type
+ ELIF last name char = "%"
+ THEN int type
+ ELSE real type FI .
+
+var or array:
+ IF array name
+ THEN name CAT "()";
+ deshift name CAT "()"; (* F30/rr *)
+ array
+ ELSE var FI .
+
+array name:
+ next scan char = "(" .
+
+deshifted char:
+ letter := act char;
+ IF letter >= "A" AND letter <= "Z"
+ THEN code (code (letter) + 32)
+ ELSE letter FI .
+
+generate delimiter:
+ name := act char; no := code (name); type := del .
+
+next scan char: record SUB pos (record, ""33"", ""255"", scan pos+1).
+next char: (record SUB scan pos + 1) .
+act char: record SUB scan pos .
+skip char: scan pos INCR 1 .
+END PROC next symbol;
+
+DTYPE PROC var datatype (TEXT CONST first name char, last name char) :
+
+ IF last name char = "!" OR last name char = "#"
+ THEN real type
+ ELIF last name char = "$"
+ THEN text type
+ ELIF last name char = "%"
+ THEN int type
+ ELIF pos (defint chars, first name char) > 0
+ THEN int type
+ ELIF pos (defstr chars, first name char) > 0
+ THEN text type
+ ELSE real type FI .
+
+END PROC var datatype;
+
+BOOL PROC next data (TEXT VAR data text, DTYPE VAR data type) : (* F17/rr *)
+
+ data type := void type;
+ IF no more data
+ THEN scan pos := rec len;
+ data text := "";
+ FALSE
+ ELIF quoted string
+ THEN get quoted string;
+ TRUE
+ ELSE get unquoted string;
+ TRUE
+ FI
+
+ . no more data :
+ scan pos := pos (record, ""33"", ""255"", scan pos+1);
+ scan pos = 0
+
+ . quoted string :
+ (record SUB scan pos) = quote
+
+ . get quoted string :
+ get text const (data text, data type);
+
+ . get unquoted string :
+ INT CONST comma or colon pos 1 := position of comma or colon minus one;
+ data text := compress (subtext (record, scan pos, comma or colon pos 1));
+ scan pos := comma or colon pos 1;
+
+ . position of comma or colon minus one :
+ INT CONST colon pos := pos (record, colon, scan pos),
+ comma pos := pos (record, comma, scan pos);
+ IF colon pos > 0
+ THEN IF comma pos > 0
+ THEN min (colon pos, comma pos) - 1
+ ELSE colon pos - 1
+ FI
+ ELSE IF comma pos > 0
+ THEN comma pos - 1
+ ELSE LENGTH record
+ FI
+ FI
+
+END PROC next data;
+
+PROC get numeric const (TEXT VAR value, DTYPE VAR data):
+ get sign;
+ get const;
+ check datatype .
+
+get sign:
+ IF act char = "-"
+ THEN value := "-";
+ scan pos INCR 1
+ ELIF act char = "+"
+ THEN value := "+";
+ scan pos INCR 1
+ ELSE value := "" FI .
+
+get const:
+ get digits;
+ get point;
+ get digits;
+ get exponent .
+
+get digits:
+ FOR scan pos FROM scan pos UPTO rec len
+ WHILE digit found
+ REP value CAT act char PER .
+
+get point:
+ IF act char = "."
+ THEN value CAT ".";
+ scan pos INCR 1
+ ELIF pos (exponent chars, act char) > 0
+ THEN value CAT ".0"
+ ELSE LEAVE get const FI .
+
+get exponent:
+ IF pos (exponent chars, act char) > 0 (* F1/rr *)
+ THEN value CAT "e";
+ scan pos INCR 1;
+ evtl get sign;
+ get digits
+ FI .
+
+evtl get sign:
+ IF act char = "+" OR act char = "-"
+ THEN value CAT act char;
+ scan pos INCR 1
+ FI .
+
+digit found:
+ "0" <= act char AND act char <= "9" .
+
+check datatype:
+ IF act char = "%"
+ THEN IF integer ok (value)
+ THEN data := int type
+ ELSE scan error (2, value, "INT-Konstante nicht korrekt") FI
+ ELIF act char = "!" OR act char = "#"
+ THEN IF real ok (value)
+ THEN data := real type
+ ELSE scan error (2, value, "REAL-Konstante nicht korrekt") FI
+ ELIF integer ok (value)
+ THEN scan pos DECR 1; data := int type
+ ELIF real ok (value)
+ THEN scan pos DECR 1;
+ data := real type
+ ELSE scan error (2, value, "Numerische Konstante nicht korrekt") FI .
+
+act char: record SUB scan pos .
+END PROC get numeric const;
+
+PROC get text const (TEXT VAR value, DTYPE VAR data):
+ INT CONST quote 1 := scan pos;
+ scan pos := pos (record, """", scan pos+1);
+ IF quote 1 < scan pos
+ THEN value := subtext (record, quote 1+1, scan pos-1);
+ data := text type
+ ELSE scan error (15, subtext (record, quote 1), "("" fehlt)") FI .
+
+END PROC get text const;
+
+BOOL PROC integer ok (TEXT VAR zahl):
+ disable stop;
+ i dummy := int (zahl);
+ IF is error
+ THEN clear error;
+ FALSE
+ ELIF last conversion ok
+ THEN zahl := ""0""0"";
+ replace (zahl, 1, i dummy);
+ TRUE
+ ELSE FALSE FI .
+
+END PROC integer ok;
+
+BOOL PROC real ok (TEXT VAR zahl):
+ disable stop;
+ r dummy := real (zahl);
+ IF is error
+ THEN clear error;
+ FALSE
+ ELIF last conversion ok
+ THEN zahl := ""0""0""0""0""0""0""0""0"";
+ replace (zahl, 1, r dummy);
+ TRUE
+ ELSE FALSE FI .
+
+END PROC real ok;
+
+PROC basic error (INT CONST no, TEXT CONST name, addition):
+ basic error ("Compiler", no, record no, act stat no, name, addition, TRUE)
+END PROC basic error;
+
+PROC basic error (INT CONST no, TEXT CONST name, addition, BOOL CONST leave statement):
+ basic error ("Compiler", no, record no, act stat no, name, addition, leave statement)
+END PROC basic error;
+
+PROC scan error (INT CONST no, TEXT CONST name, addition):
+ basic error ("Scanner", no, record no, act stat no, name, addition, TRUE)
+END PROC scan error;
+
+PROC basic warning (TEXT CONST warning text): (* mo *)
+ basic warning (record no, act stat no, warning text)
+END PROC basic warning;
+
+PROC basic list (BOOL CONST t):
+ listing := t
+END PROC basic list;
+
+BOOL PROC basic list:
+ listing
+END PROC basic list;
+
+PROC set scope (TEXT CONST new scope): (* DEF/mo *)
+ scope := new scope
+END PROC set scope;
+
+TEXT PROC scanner scope: (* DEF/mo *)
+ scope
+END PROC scanner scope;
+
+END PACKET basic scanner;
+
+
+PACKET basic stat no DEFINES init stat no, (* Autor: Heiko Indenbirken *)
+ stat no pos, (* Stand: 27.10.1987/rr/mo *)
+ label pos,
+ all stat no:
+
+LET nil = "";
+
+TEXT VAR found stat no :: nil;
+INT VAR i, akt stat no :: 0, found no :: 0;
+
+PROC init stat no (FILE VAR f, INT VAR error no): (* F21/rr *)
+(*Die Datei 'f' muß im 'modify-Mode' sein. *)
+ INT VAR line no;
+ akt stat no := -1; (* F28/rr *)
+ found no := 0;
+ found stat no := nil;
+ error no := 0; (* F21/rr *)
+ to first record (f);
+ col (f, 1);
+ disable stop;
+ FOR line no FROM 1 UPTO 4000
+ REP exec (PROC (TEXT CONST, INT CONST) check, f, line no);
+ IF is error THEN check error FI;
+ IF eof (f)
+ THEN LEAVE init stat no
+ ELSE down (f) FI
+ PER;
+
+. check error : (* F21/rr *)
+ IF error code = 100
+ THEN clear error;
+ error no INCR 1;
+ ELSE LEAVE init stat no;
+ FI;
+
+END PROC init stat no;
+
+PROC check (TEXT CONST record, INT CONST line no):
+ IF statement no vorhanden
+ THEN remember statement no FI .
+
+statement no vorhanden: (* F15/rr *)
+ INT CONST first number pos := pos (record, ""048"", ""057"", 1);
+ first number pos > 0 CAND first number pos = first non blank pos .
+
+first non blank pos : (* F15/rr *)
+ pos (record, ""033"", ""255"", 1) .
+
+remember statement no:
+ get statement no;
+ IF neue nummer ist groesser als vorherige
+ THEN akt stat no := neue nummer;
+ cout (neue nummer);
+ found no INCR 1;
+ found stat no CAT mki (neue nummer)
+ ELSE basic error ("Stat no", 81, line no, neue nummer, number,
+ "Letzte Zeilennummer davor: " + text (akt stat no), TRUE)
+ FI .
+
+get statement no : (* F15/rr *)
+ disable stop;
+ TEXT CONST number := subtext (record, first number pos, last number pos);
+ INT VAR neue nummer := int (number);
+ IF NOT last conversion ok OR is error
+ THEN clear error;
+ basic error ("Stat no", 80, line no, akt stat no, number,
+ "Die Zeilennummer muß im Bereich 0-32767 liegen", TRUE)
+ FI;
+ enable stop .
+
+last number pos : (* F15/rr *)
+ INT CONST high := pos (record, ""058"", ""255"", first number pos),
+ low := pos (record, ""032"", ""047"", first number pos);
+ IF high > 0
+ THEN IF low > 0
+ THEN min (high, low) - 1
+ ELSE high - 1
+ FI
+ ELIF low > 0
+ THEN low - 1
+ ELSE LENGTH record
+ FI .
+
+neue nummer ist groesser als vorherige:
+ neue nummer > akt stat no .
+
+END PROC check;
+
+INT PROC stat no pos (INT CONST stat no):
+ FOR i FROM found no DOWNTO 1
+ REP IF (found stat no ISUB i) = stat no
+ THEN LEAVE stat no pos WITH i FI
+ PER;
+ 0
+END PROC stat no pos;
+
+INT PROC label pos (INT CONST stat no):
+ FOR i FROM found no DOWNTO 1
+ REP IF (found stat no ISUB i) = stat no
+ THEN LEAVE label pos WITH i FI
+ PER;
+ basic error (8, text (stat no), nil); (* F16/rr *)
+ 0
+END PROC label pos;
+
+PROC all stat no (TEXT VAR stat no, INT VAR no):
+ stat no := found stat no;
+ no := found no
+END PROC all stat no;
+
+END PACKET basic stat no;
+
+PACKET basic storage DEFINES init storage, (* Autor: Heiko Indenbirken *)
+ next local adr, (* Stand: 12.06.86 *)
+ next ref,
+ local adr,
+ local storage,
+ type size,
+ quiet type:
+
+
+
+LET ref length = 2;
+
+INT VAR quiet size, quiet align;
+ADDRESS VAR loc adr, free loc adr;
+DTYPE VAR quiet value;
+identify ("QUIET", quiet size, quiet align, quiet value);
+
+PROC init storage:
+ free loc adr := LOC 0;
+ loc adr := LOC 0;
+
+END PROC init storage;
+
+(* Verwaltung der lokalen Addressen für Zwischenergebnisse *)
+ADDRESS PROC next local adr (DTYPE CONST type):
+ INT VAR type len :: type size (type);
+ loc adr := free loc adr;
+ adjust (loc adr, type len);
+ free loc adr := loc adr + type len;
+ loc adr .
+
+END PROC next local adr;
+
+ADDRESS PROC next ref:
+ loc adr := free loc adr;
+ adjust (loc adr, ref length);
+ free loc adr := loc adr + ref length;
+ loc adr .
+
+END PROC next ref;
+
+ADDRESS PROC local adr:
+ loc adr
+END PROC local adr;
+
+INT PROC local storage:
+ int (subtext (dump (free loc adr), 6))
+END PROC local storage;
+
+INT PROC type size (DTYPE CONST type):
+ IF type = int type OR type = bool type
+ THEN 1
+ ELIF type = row type
+ THEN 2
+ ELIF type = real type
+ THEN 4
+ ELIF type = text type
+ THEN 8
+ ELIF type = quiet value
+ THEN quiet size
+ ELSE errorstop ("Unbekannter DTYPE: " + dump (type)); 0 FI .
+
+END PROC type size;
+
+DTYPE PROC quiet type:
+ quiet value
+END PROC quiet type;
+
+END PACKET basic storage;
+
+PACKET basic identify DEFINES (* Autor: Heiko Indenbirken *)
+ (* Stand: 20.08.1987/rr/mo *)
+ identify,
+ convert paramfield,
+ dump ftn,
+ is basic function: (* mo *)
+
+LET nil = "";
+
+LET ENTRY = STRUCT (TEXT param, INT no, next, OPN opn, DTYPE result);
+
+ROW 256 ENTRY VAR ftn table;
+
+clear ftn table;
+init ftn names;
+init int operator;
+init real operator;
+init text operator;
+init predefined funktions;
+
+PROC dump ftn (INT CONST n, TEXT VAR param, INT VAR no, next,
+ OPN VAR opn, DTYPE VAR result):
+ param := ftn table [n].param;
+ no := ftn table [n].no;
+ next := ftn table [n].next;
+ opn := ftn table [n].opn;
+ result := ftn table [n].result
+
+END PROC dump ftn;
+
+PROC identify (INT CONST ftn no, first, params, OPN VAR operation, BOOL VAR found):
+ TEXT VAR param;
+ INT VAR pos :: min (ftn no, 256);
+ convert paramfield (first, params, param);
+ REP IF param = ftn table [pos].param AND ftn no = ftn table [pos].no
+ THEN declare (params+1, ftn table [pos].result);
+ declare (params+1, 1);
+ operation := ftn table [pos].opn;
+ found := TRUE;
+ LEAVE identify
+ ELSE pos := ftn table [pos].next FI
+ UNTIL pos <= 0 PER; (* F14/rr *)
+ operation := nop;
+ found := FALSE .
+
+END PROC identify;
+
+PROC next free entry (INT VAR free pos):
+ FOR free pos FROM 1 UPTO 256
+ REP IF ftn table [free pos].next < 0 AND ftn table [free pos].no = 0 (* mo *)
+ THEN LEAVE next free entry FI
+ PER;
+ errorstop ("Überlauf der Funktionstabelle") .
+
+END PROC next free entry;
+
+PROC convert paramfield (INT CONST first, params, TEXT VAR param):
+ INT VAR i;
+ param := nil;
+ FOR i FROM first UPTO params
+ REP param CAT datatype PER .
+
+datatype:
+ DTYPE CONST data :: dtype (i);
+ IF data = int type
+ THEN "I"
+ ELIF data = real type
+ THEN "R"
+ ELIF data = text type
+ THEN "T"
+ ELIF data = bool type
+ THEN "b"
+ ELSE errorstop ("Falscher DTYPE: " + dump (data));
+ nil
+ FI .
+
+END PROC convert paramfield;
+
+PROC convert paramfield (TEXT CONST params, INT CONST first):
+ INT VAR i;
+ FOR i FROM first UPTO first+length (params)-1
+ REP parameter (i, this type, 1, GLOB 0) PER .
+
+this type:
+ IF (params SUB i) = "I"
+ THEN int type
+ ELIF (params SUB i) = "R"
+ THEN real type
+ ELIF (params SUB i) = "T"
+ THEN text type
+ ELSE errorstop ("Unbekannter Typ: " + params);
+ undefined type
+ FI .
+
+END PROC convert paramfield;
+
+PROC init op (INT CONST ftn no, TEXT CONST param, ftn name):
+ IF elan opn found
+ THEN insert new opn in chain
+ ELSE errorstop ("PROC " + ftn name + " (" + param + ") nicht gefunden") FI .
+
+elan opn found:
+ OPN VAR opn;
+ BOOL VAR found;
+ convert paramfield (param, 1);
+ identify (ftn name, 1, length (param), opn, found);
+ found .
+
+insert new opn in chain:
+ INT VAR ftn pos :: ftn no;
+ REP IF end of chain found
+ THEN cat new entry in chain
+ ELIF free entry in chain found
+ THEN cover this entry
+ ELSE next entry FI
+ UNTIL ftn pos <= 0 PER .
+
+end of chain found:
+ act entry.next = 0 .
+
+cat new entry in chain:
+ INT VAR free pos;
+ next free entry (free pos);
+ act entry.next := free pos;
+ free entry := ENTRY:(param, ftn no, 0, opn, dtype (LENGTH param+1));
+ LEAVE insert new opn in chain .
+
+free entry in chain found:
+ act entry.next = -1 .
+
+cover this entry:
+ act entry := ENTRY:(param, ftn no, 0, opn, dtype (LENGTH param+1));
+ LEAVE insert new opn in chain .
+
+next entry:
+ ftn pos := act entry.next .
+
+act entry: ftn table [ftn pos] .
+free entry: ftn table [free pos] .
+
+END PROC init op;
+
+BOOL PROC is basic function (INT CONST ftn no): (* mo *)
+
+ pos (ftn names, code (ftn no)) <> 0
+
+END PROC is basic function;
+
+.
+clear ftn table:
+ INT VAR k;
+ FOR k FROM 1 UPTO 256
+ REP ftn table [k] := ENTRY:(nil, 0,-1, nop, undefined type) PER .
+
+init ftn names:
+ TEXT CONST ftn names :: "+-*/\^<=>"28""29""30""249""251""252""253""254"" +
+ ""128""130""131""134""136""137""141""143""142"" +
+ ""153""154""155""157""159""161""166""168""170""171""172"" +
+ ""174""175""178""179""182""184""183""187""192"" +
+ ""201""202""204""205""206""207""208""211""212"" +
+ ""215""221""228""229""230""231""232""233"";
+ FOR k FROM 1 UPTO length (ftn names)
+ REP ftn table [ftn pos] := ENTRY:(nil, ftn pos,-1, nop, void type) PER .
+
+ftn pos:
+ code (ftn names SUB k) .
+
+init int operator:
+ init op ( 43, "II", "+");
+ init op ( 45, "II", "-");
+ init op ( 42, "II", "*");
+ init op ( 47, "II", "/"); (* mo *)
+ init op ( 92, "II", "DIV"); (* mo *)
+ init op ( 94, "II", "^");
+ init op ( 61, "II", "EQU");
+ init op ( 29, "II", "UEQ");
+ init op ( 60, "II", "LES");
+ init op ( 28, "II", "LEQ");
+ init op ( 62, "II", "GRE");
+ init op ( 30, "II", "GEQ");
+ init op (249, "II", "MOD"); (* mo *)
+ init op (251, "II", "AND");
+ init op (252, "II", "OR");
+ init op (253, "II", "XOR");
+ init op (254, "II", "EQV");
+ init op (255, "II", "IMP").
+
+init real operator:
+ init op ( 43, "RR", "+");
+ init op ( 45, "RR", "-");
+ init op ( 42, "RR", "*");
+ init op ( 47, "RR", "/");
+ init op ( 92, "RR", "DIV"); (* mo *)
+ init op ( 94, "RR", "^");
+ init op ( 61, "RR", "EQU");
+ init op ( 29, "RR", "UEQ");
+ init op ( 60, "RR", "LES");
+ init op ( 28, "RR", "LEQ");
+ init op ( 62, "RR", "GRE");
+ init op ( 30, "RR", "GEQ");
+ init op (249, "RR", "realmod"). (* mo *)
+
+init text operator:
+ init op ( 43, "TT", "+");
+ init op ( 61, "TT", "EQU");
+ init op ( 29, "TT", "UEQ");
+ init op ( 60, "TT", "LES");
+ init op ( 28, "TT", "LEQ");
+ init op ( 62, "TT", "GRE");
+ init op ( 30, "TT", "GEQ") .
+
+init predefined funktions:
+ init op (128, "I", "abs");
+ init op (128, "R", "abs");
+ init op (130, "T", "asc");
+ init op (131, "R", "arctan");
+ init op (131, "I", "arctan");
+ init op (134, "I", "cdbl");
+ init op (134, "R", "cdbl");
+ init op (136, "I", "chr");
+ init op (136, "R", "chr");
+ init op (137, "R", "cint");
+ init op (137, "I", "cint");
+ init op (141, "R", "cos");
+ init op (141, "I", "cos");
+ init op (143, "T", "cvi");
+ init op (142, "T", "cvd");
+# init op (153, "", "eof");# (* File *)
+ init op (154, "", "errorline");
+ init op (155, "", "errorcode");
+ init op (157, "R", "exp");
+ init op (157, "I", "exp");
+ init op (159, "R", "floor");
+ init op (159, "I", "floor");
+ init op (161, "I", "fre");
+ init op (161, "R", "fre");
+ init op (161, "T", "fre");
+ init op (166, "I", "hex");
+ init op (166, "R", "hex");
+ init op (168, "", "incharety");
+ init op (170, "I", "inchars");
+ init op (170, "R", "inchars");
+ init op (171, "TT", "instr");
+ init op (171, "ITT", "instr");
+ init op (171, "RTT", "instr");
+ init op (172, "I", "ent");
+ init op (172, "R", "ent");
+ init op (174, "TI", "left");
+ init op (174, "TR", "left");
+ init op (175, "T", "length");
+# init op (178, "I", "line no");# (* File *)
+ init op (179, "R", "ln");
+ init op (179, "I", "ln");
+ init op (182, "TII", "mid");
+ init op (182, "TI", "mid");
+ init op (182, "TRR", "mid");
+ init op (182, "TR", "mid");
+ init op (183, "I", "mkd");
+ init op (183, "R", "mkd");
+ init op (187, "I", "oct");
+ init op (187, "R", "oct");
+ init op (192, "I", "pos");
+ init op (192, "R", "pos");
+ init op (201, "TI", "right");
+ init op (201, "TR", "right");
+ init op (202, "", "rnd"); (* F12/rr *)
+ init op (202, "I", "rnd");
+ init op (202, "R", "rnd");
+ init op (204, "I", "sign");
+ init op (204, "R", "sign");
+ init op (205, "R", "sin");
+ init op (205, "I", "sin");
+ init op (206, "I", "space");
+ init op (206, "R", "space");
+ init op (207, "I", "space");
+ init op (207, "R", "space");
+ init op (208, "R", "sqrt");
+ init op (208, "I", "sqrt");
+ init op (211, "I", "basictext");
+ init op (211, "R", "basictext");
+ init op (212, "IT", "string");
+ init op (212, "RT", "string");
+ init op (212, "II", "string");
+ init op (212, "RR", "string");
+ init op (212, "RI", "string");
+ init op (212, "IR", "string");
+ init op (215, "R", "tan");
+ init op (215, "I", "tan");
+ init op (221, "T", "val"); (* F18/rr *)
+ init op (228, "", "errormessage");
+ init op (229, "", "csrlin");
+ init op (230, "I", "lpos");
+ init op (230, "R", "lpos");
+ init op (231, "", "time");
+ init op (232, "", "date");
+ init op (233, "", "timer").
+
+END PACKET basic identify;
+
+PACKET basic data handling (* Autor: R. Ruland *)
+ (* Stand: 23.10.87/mo *)
+ DEFINES init data,
+ data line,
+ data, read,
+ restore,
+ next int,
+ next real,
+ next text:
+
+LET (* R e s u l t T y p e n *)
+ stat code = 0, stat char = ""0"",
+ data code = 1, data char = ""1"",
+ text code = 2, text char = ""2"",
+
+ int overflow = 4,
+ real overflow = 6;
+
+INT VAR type;
+TEXT VAR data text :: "", number text;
+
+PROC init data:
+
+ data text := ""
+
+END PROC init data;
+
+
+PROC init data (TEXT VAR data, INT VAR data pos):
+
+ data := data text;
+ data pos := 1
+
+END PROC init data;
+
+
+PROC restore (TEXT CONST data, INT VAR data pos, INT CONST line no):
+
+ INT CONST data length :: LENGTH data;
+ data pos := 1;
+ WHILE data pos < data length
+ REP type := code (data SUB data pos);
+ data pos INCR 1;
+ SELECT type OF
+ CASE stat code : IF int value (data, data pos) >= line no
+ THEN LEAVE restore FI
+ CASE data code, text code : data pos INCR int value (data, data pos)
+ OTHERWISE : errorstop (1051, "Fehlerhaften Dateneintrag gefunden: " + text (type))
+ ENDSELECT;
+ PER;
+ errorstop (1004, "RESTORE: Keine DATA-Anweisung in oder nach Zeile " + text (line no)
+ + " gefunden");
+
+END PROC restore;
+
+
+INT PROC next int (TEXT CONST data, INT VAR data pos):
+
+ number text := next text (data, data pos);
+ disable stop;
+ INT VAR result := int (number text);
+ IF is error
+ THEN IF error code = int overflow THEN handle overflow FI;
+ ELIF NOT last conversion ok CAND number text <> ""
+ THEN errorstop (1013, "READ: Falscher Datentyp, " + number text + " ist kein INT")
+ FI;
+ result
+
+ . handle overflow :
+ clear error;
+ result := result value;
+ IF cursor x pos <> 1 THEN next line FI;
+ basic out ("WARNUNG : INT-Überlauf bei READ, gefunden: " + number text);
+ next line;
+
+ . result value :
+ IF (number text SUB 1) = "-" THEN minint ELSE maxint FI
+
+END PROC next int;
+
+
+REAL PROC next real (TEXT CONST data, INT VAR data pos):
+
+ number text := next text (data, data pos);
+ disable stop;
+ REAL VAR result := val (number text);
+ IF is error
+ THEN IF error code = real overflow OR error code = int overflow (* <- wegen Fehler in REAL PROC real (T C) *)
+ THEN handle overflow or underflow
+ FI;
+ ELIF NOT last conversion ok CAND number text <> ""
+ THEN errorstop (1013, "READ: Falscher Datentyp, " + number text + " ist kein REAL")
+ FI;
+ result
+
+ . handle overflow or underflow : (* F23/rr *)
+ clear error;
+ IF cursor x pos <> 1 THEN next line FI;
+ basic out ("WARNUNG : " + overflow or underflow + " bei READ, gefunden: " + number text);
+ next line;
+
+ . overflow or underflow :
+ IF is overflow
+ THEN result := sign * (max real - 0.99999999999994e120); (* <- wegen Fehler in TEXT PROC text (R C) *)
+ "REAL-Überlauf"
+ ELSE result := 0.0;
+ "REAL-Unterlauf"
+ FI
+
+ . sign :
+ IF (number text SUB 1) = "-" THEN -1.0 ELSE 1.0 FI
+
+ . is overflow :
+ INT VAR exponent pos := pos (number text, "E");
+ IF exponent pos = 0 THEN exponent pos := pos (number text, "e") FI;
+ IF exponent pos = 0
+ THEN TRUE
+ ELSE (number text SUB (exponent pos + 1)) <> "-"
+ FI
+
+END PROC next real;
+
+
+TEXT PROC next text (TEXT CONST data, INT VAR data pos):
+
+ INT CONST len :: int value (data, data pos);
+ data pos INCR len;
+ subtext (data, data pos-len, data pos-1)
+
+END PROC next text;
+
+
+INT PROC int value (TEXT CONST data, INT VAR data pos):
+
+ data pos INCR 2;
+ subtext (data, data pos-2, data pos-1) ISUB 1
+
+END PROC int value;
+
+
+PROC data line (INT CONST line no):
+
+ data text CAT stat char;
+ data text CAT mki (line no)
+
+END PROC data line;
+
+
+PROC data (TEXT CONST string, DTYPE VAR data type) :
+
+ data text CAT data + mki (length (string));
+ data text CAT string;
+
+ . data :
+ IF data type = void type
+ THEN data char
+ ELIF data type = text type
+ THEN text char
+ ELSE errorstop (1051, "Unbekannter DTYPE: " + dump (data type)); ""
+ FI
+
+END PROC data;
+
+
+PROC read (TEXT CONST data, INT VAR data pos, INT VAR i):
+
+ type := code (data SUB data pos);
+ data pos INCR 1;
+ IF data pos >= LENGTH data
+ THEN errorstop (1004, "Keine Daten mehr für READ")
+ ELIF type = data code
+ THEN i := next int (data, data pos)
+ ELIF type = stat code
+ THEN data pos INCR 2;
+ read (data, data pos, i)
+ ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein INT")
+ FI;
+
+END PROC read;
+
+
+PROC read (TEXT CONST data, INT VAR data pos, REAL VAR r):
+
+ type := code (data SUB data pos);
+ data pos INCR 1;
+ IF data pos >= LENGTH data
+ THEN errorstop (1004, "Keine Daten mehr für READ")
+ ELIF type = data code
+ THEN r := next real (data, data pos)
+ ELIF type = stat code
+ THEN data pos INCR 2;
+ read (data, data pos, r)
+ ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein REAL")
+ FI;
+
+END PROC read;
+
+
+PROC read (TEXT CONST data, INT VAR data pos, TEXT VAR t):
+
+ type := code (data SUB data pos);
+ data pos INCR 1;
+ IF data pos >= LENGTH data
+ THEN errorstop (1004, "Keine Daten mehr für READ")
+ ELIF type = data code OR type = text code
+ THEN t := next text (data, data pos)
+ ELIF type = stat code
+ THEN data pos INCR 2;
+ read (data, data pos, t)
+ ELSE errorstop (1013, "READ: Falscher Datentyp, " + data string (data,data pos) + " ist kein TEXT")
+ FI;
+
+END PROC read;
+
+
+TEXT PROC data string (TEXT CONST data, INT VAR data pos):
+
+ IF type = text code
+ THEN """" + next text (data, data pos) + """"
+ ELSE "unbekannter DTYPE: " + text (type)
+ FI
+
+END PROC data string;
+
+END PACKET basic data handling;
+
+
+PACKET basic odds and ends DEFINES trace, (* Autor: Heiko Indenbirken *)
+ start basic, (* Stand: 26.10.1987/rr/mo *)
+ end basic,
+ loop end,
+ basic stop:
+
+(* Fehlerbehandlung *)
+
+PROC trace (INT CONST stat no):
+ basic out ("[" + text (stat no) + "]")
+
+END PROC trace;
+
+(*Laufzeitprozeduren *)
+PROC start basic:
+ set line nr (0);
+ initialize random (0.1); (* F26/rr *)
+ init output;
+ init input
+
+END PROC start basic;
+
+PROC end basic:
+ IF is error
+ THEN switch back to old sysout state
+ FI .
+
+END PROC end basic;
+
+(* Schleifenüberprüfung *)
+BOOL PROC loop end (REAL CONST x, max, step) :
+ IF step > 0.0
+ THEN x > max
+ ELSE x < max FI
+
+END PROC loop end;
+
+BOOL PROC loop end (INT CONST x, max, step) :
+ IF step > 0
+ THEN x > max
+ ELSE x < max FI
+
+END PROC loop end;
+
+PROC basic stop (INT CONST stat no):
+ basic out ("STOP beendet das Programm in Zeile " + text (stat no));
+ next line
+
+END PROC basic stop;
+
+END PACKET basic odds and ends
+
diff --git a/lang/basic/1.8.7/src/BASIC.Compiler b/lang/basic/1.8.7/src/BASIC.Compiler
new file mode 100644
index 0000000..d4e4c21
--- /dev/null
+++ b/lang/basic/1.8.7/src/BASIC.Compiler
@@ -0,0 +1,2305 @@
+(***************************************************************************)
+(* *)
+(* 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
+
diff --git a/lang/basic/1.8.7/src/BASIC.Runtime b/lang/basic/1.8.7/src/BASIC.Runtime
new file mode 100644
index 0000000..854002a
--- /dev/null
+++ b/lang/basic/1.8.7/src/BASIC.Runtime
@@ -0,0 +1,1571 @@
+(***************************************************************************)
+(* *)
+(* Erste von drei Dateien des EUMEL-BASIC-Systems *)
+(* *)
+(* Autor: Heiko Indenbirken *)
+(* Überarbeitet von: Rudolf Ruland und Michael Overdick *)
+(* *)
+(* Stand: 27.10.1987 *)
+(* *)
+(***************************************************************************)
+
+PACKET basic std DEFINES EQU, UEQ, (* Autor: Heiko Indenbirken *)
+ LES, LEQ, (* Stand: 23.10.1987/rr/mo *)
+ GRE, GEQ,
+ EQV, IMP,
+ ^, swap,
+ val, asc, cdbl, chr,
+ cint, cvi, cvd, fre,
+ hex, inchars,
+ instr, ent, left,
+ mid, mki, mkd,
+ oct, right,
+ rnd, init rnd,
+ space, string,
+ l set, r set,
+ int not, real not,
+ /, DIV, real mod,
+ time, timer,
+ arctan, cos, sin, tan,
+ exp, ln, floor,
+ sqrt:
+
+
+INT CONST true := -1,
+ false := 0;
+
+LET real overflow = 6;
+
+
+(*BASIC-Integervergleiche *)
+INT OP EQU (INT CONST a, b):
+ IF a=b
+ THEN true
+ ELSE false FI
+END OP EQU;
+
+INT OP UEQ (INT CONST a, b):
+ IF a=b
+ THEN false
+ ELSE true FI
+END OP UEQ;
+
+INT OP LES (INT CONST a, b):
+ IF a<b
+ THEN true
+ ELSE false FI
+END OP LES;
+
+INT OP LEQ (INT CONST a, b):
+ IF a<=b
+ THEN true
+ ELSE false FI
+END OP LEQ;
+
+INT OP GRE (INT CONST a, b):
+ IF a>b
+ THEN true
+ ELSE false FI
+END OP GRE;
+
+INT OP GEQ (INT CONST a, b):
+ IF a>=b
+ THEN true
+ ELSE false FI
+END OP GEQ;
+
+(*BASIC-Realvergleiche *)
+INT OP EQU (REAL CONST a, b):
+ IF a=b
+ THEN true
+ ELSE false FI
+END OP EQU;
+
+INT OP UEQ (REAL CONST a, b):
+ IF a=b
+ THEN false
+ ELSE true FI
+END OP UEQ;
+
+INT OP LES (REAL CONST a, b):
+ IF a<b
+ THEN true
+ ELSE false FI
+END OP LES;
+
+INT OP LEQ (REAL CONST a, b):
+ IF a<=b
+ THEN true
+ ELSE false FI
+END OP LEQ;
+
+INT OP GRE (REAL CONST a, b):
+ IF a>b
+ THEN true
+ ELSE false FI
+END OP GRE;
+
+INT OP GEQ (REAL CONST a, b):
+ IF a>=b
+ THEN true
+ ELSE false FI
+END OP GEQ;
+
+(*BASIC-Tesxtvergleiche *)
+INT OP EQU (TEXT CONST a, b):
+ IF a=b
+ THEN true
+ ELSE false FI
+END OP EQU;
+
+INT OP UEQ (TEXT CONST a, b):
+ IF a=b
+ THEN false
+ ELSE true FI
+END OP UEQ;
+
+INT OP LES (TEXT CONST a, b):
+ IF a<b
+ THEN true
+ ELSE false FI
+END OP LES;
+
+INT OP LEQ (TEXT CONST a, b):
+ IF a<=b
+ THEN true
+ ELSE false FI
+END OP LEQ;
+
+INT OP GRE (TEXT CONST a, b):
+ IF a>b
+ THEN true
+ ELSE false FI
+END OP GRE;
+
+INT OP GEQ (TEXT CONST a, b):
+ IF a>=b
+ THEN true
+ ELSE false FI
+END OP GEQ;
+
+
+(*BASIC INTEGER / BOOL Operatoren *)
+REAL PROC real not (REAL CONST a): (* mo *)
+ real (int (a) XOR -1)
+END PROC real not;
+
+INT PROC int not (INT CONST a): (* mo *)
+ a XOR -1
+END PROC int not;
+
+INT OP EQV (INT CONST l, r):
+ int not (l XOR r)
+END OP EQV;
+
+INT OP IMP (INT CONST l, r):
+ (l EQV r) OR r
+END OP IMP;
+
+LET smallest significant = 5.0e-12;
+REAL OP ^ (REAL CONST x, y): (* F22/rr *)
+ IF x > 0.0
+ THEN x ** y
+ ELIF x = 0.0
+ THEN IF y > 0.0
+ THEN 0.0
+ ELIF y = 0.0
+ THEN 1.0
+ ELSE errorstop (real overflow, "");
+ max real
+ FI
+ ELSE REAL VAR floor y := floor (y + round value);
+ IF (abs (y - floor y) > smallest significant)
+ COR (floor y = 0.0 AND y <> 0.0)
+ THEN errorstop (1005, "bei " + text (x) +
+ " ^ " + text (y, 19) +
+ " : neg. Basis, gebr. Exponent");
+ 0.0
+ ELIF (floor y MOD 2.0) = 0.0
+ THEN (-x) ** floor y
+ ELSE - ( (-x) ** floor y )
+ FI
+ FI .
+
+ round value : IF y >= 0.0 THEN 0.5 ELSE -0.5 FI .
+
+END OP ^;
+
+REAL OP ^ (INT CONST x, y):
+ real (x) ** y
+END OP ^;
+
+REAL OP / (INT CONST l, r): (* mo *)
+ real (l) / real (r)
+END OP /;
+
+INT OP DIV (REAL CONST l, r): (* mo *)
+ cint (l) DIV cint (r)
+END OP DIV;
+
+REAL PROC real mod (REAL CONST l, r): (* mo *)
+ round (l, 0) MOD round (r, 0)
+END PROC real mod;
+
+(* Basic Arithmetik *)
+REAL VAR r swap;
+PROC swap (REAL VAR left, right):
+ r swap := left;
+ left := right;
+ right := r swap
+END PROC swap;
+
+INT VAR i swap;
+PROC swap (INT VAR left, right):
+ i swap := left;
+ left := right;
+ right := i swap
+END PROC swap;
+
+TEXT VAR t swap;
+PROC swap (TEXT VAR left, right):
+ t swap := left;
+ left := right;
+ right := t swap
+END PROC swap;
+
+(*Internkonvertierungen *)
+INT PROC cvi (TEXT CONST v):
+ v ISUB 1
+END PROC cvi;
+
+REAL PROC cvd (TEXT CONST v):
+ v RSUB 1
+END PROC cvd;
+
+TEXT VAR i text :: 2*""0"", r text :: 8*""0"";
+TEXT PROC mki (REAL CONST x):
+ mki (cint (x))
+END PROC mki;
+
+TEXT PROC mki (INT CONST i):
+ replace (i text, 1, i);
+ i text
+END PROC mki;
+
+TEXT PROC mkd (INT CONST i):
+ mkd (real (i))
+END PROC mkd;
+
+TEXT PROC mkd (REAL CONST r):
+ replace (r text, 1, r);
+ r text
+END PROC mkd;
+
+(*Textoperationen *)
+PROC l set (TEXT VAR left, TEXT CONST right):
+ replace (left, 1, right)
+END PROC l set;
+
+PROC r set (TEXT VAR left, TEXT CONST right):
+ replace (left, length (left)-length (right)+1, right)
+END PROC r set;
+
+TEXT PROC left (TEXT CONST string, REAL CONST no):
+ left (string, cint (no))
+END PROC left;
+
+TEXT PROC left (TEXT CONST string, INT CONST no):
+ subtext (string, 1, no)
+END PROC left;
+
+TEXT PROC right (TEXT CONST string, REAL CONST no):
+ right (string, cint (no))
+END PROC right;
+
+TEXT PROC right (TEXT CONST string, INT CONST no):
+ subtext (string, length (string)-no+1)
+END PROC right;
+
+TEXT PROC mid (TEXT CONST source, REAL CONST from):
+ mid (source, cint (from))
+END PROC mid;
+
+TEXT PROC mid (TEXT CONST source, INT CONST from):
+ subtext (source, from)
+END PROC mid;
+
+TEXT PROC mid (TEXT CONST source, REAL CONST from, length):
+ mid (source, cint (from), cint (length))
+END PROC mid;
+
+TEXT PROC mid (TEXT CONST source, INT CONST from, length):
+ subtext (source, from, from+length-1)
+END PROC mid;
+
+TEXT PROC string (REAL CONST x, y):
+ string (cint (x), cint (y))
+END PROC string;
+
+TEXT PROC string (INT CONST x, REAL CONST y):
+ string (x, cint (y))
+END PROC string;
+
+TEXT PROC string (REAL CONST x, INT CONST y):
+ string (cint (x), y)
+END PROC string;
+
+TEXT PROC string (INT CONST i, j):
+ i * code (j)
+END PROC string;
+
+TEXT PROC string (REAL CONST i, TEXT CONST x):
+ string (cint (i), x)
+END PROC string;
+
+TEXT PROC string (INT CONST i, TEXT CONST x):
+ i * (x SUB 1)
+END PROC string;
+
+(*Konvertierungen *)
+
+REAL PROC val (TEXT CONST text) : (* F18/rr *)
+
+ TEXT VAR buffer := text;
+ change (buffer, "d", "e");
+ change (buffer, "D", "e");
+ change (buffer, "E", "e");
+ real (buffer)
+
+END PROC val;
+
+REAL PROC asc (TEXT CONST text):
+ real (code (text SUB 1))
+END PROC asc;
+
+TEXT PROC chr (INT CONST n):
+ code (n)
+END PROC chr;
+
+TEXT PROC chr (REAL CONST n):
+ code (cint (n))
+END PROC chr;
+
+TEXT PROC hex (REAL CONST x):
+ hex (cint (x))
+END PROC hex;
+
+TEXT PROC hex (INT CONST x):
+ TEXT VAR value :: "12";
+ replace (value, 1, x);
+ high byte + low byte .
+
+low byte:
+ hexdigit (code (value SUB 1) DIV 16) + hexdigit (code (value SUB 1) MOD 16) .
+
+high byte:
+ IF (value SUB 2) = ""0""
+ THEN ""
+ ELSE hexdigit (code (value SUB 2) DIV 16) +
+ hexdigit (code (value SUB 2) MOD 16)
+ FI .
+
+END PROC hex;
+
+TEXT PROC oct (REAL CONST x):
+ oct (cint (x))
+END PROC oct;
+
+TEXT PROC oct (INT CONST x):
+ INT VAR number :: x AND maxint;
+ generate oct number;
+ IF x < 0
+ THEN "1" + oct number
+ ELSE subtext (oct number, pos (oct number, "1", "7", 1))
+ FI.
+
+generate oct number:
+ TEXT VAR oct number :: "";
+ INT VAR digit;
+ FOR digit FROM 1 UPTO 5 REP
+ oct number := hexdigit (number MOD 8) + oct number;
+ number := number DIV 8
+ PER.
+
+END PROC oct;
+
+TEXT PROC hexdigit (INT CONST digit):
+ IF 0 <= digit AND digit <= 9
+ THEN code (digit + 48)
+ ELIF 10 <= digit AND digit <= 15
+ THEN code (digit + 55)
+ ELSE errorstop (1051, "Hexziffer außerhalb des gültigen Bereichs"); "" FI
+END PROC hexdigit;
+
+TEXT PROC inchars (REAL CONST n):
+ inchars (cint (n))
+END PROC inchars;
+
+TEXT PROC inchars (INT CONST n):
+ TEXT VAR buffer :: "", char;
+ INT VAR i;
+ FOR i FROM 1 UPTO n
+ REP inchar (char);
+ buffer CAT char
+ PER;
+ buffer
+
+END PROC inchars;
+
+(*Mathematische Prozeduren *)
+REAL PROC ent (INT CONST r):
+ real (r)
+END PROC ent;
+
+REAL PROC ent (REAL CONST r):
+ IF r >= 0.0 OR frac (r) = 0.0
+ THEN floor (r)
+ ELSE floor (r-1.0) FI
+END PROC ent;
+
+REAL PROC cdbl (INT CONST r):
+ real (r)
+END PROC cdbl;
+
+REAL PROC cdbl (REAL CONST r):
+ r
+END PROC cdbl;
+
+INT PROC cint (INT CONST r):
+ r
+END PROC cint;
+
+INT PROC cint (REAL CONST r):
+ IF r >= 0.0
+ THEN int (r+0.5)
+ ELSE int (r-0.5) FI
+END PROC cint;
+
+REAL VAR last rnd :: rnd (1.0);
+REAL PROC rnd (INT CONST x):
+ rnd (real (x))
+END PROC rnd;
+
+REAL PROC rnd (REAL CONST x):
+ IF x > 0.0
+ THEN last rnd := random;
+ last rnd
+ ELIF x = 0.0
+ THEN last rnd
+ ELSE init rnd (x);
+ last rnd := random;
+ last rnd
+ FI
+
+END PROC rnd;
+
+REAL PROC rnd:
+ rnd (1.0)
+END PROC rnd;
+
+PROC init rnd (REAL CONST init value) :
+
+ REAL VAR init := init value;
+ IF init <= -1.0 OR 1.0 <= init
+ THEN set exp (- decimal exponent (init) - 1, init) FI;
+ initialize random (init)
+
+END PROC init rnd;
+
+
+REAL PROC fre (TEXT CONST dummy):
+ INT VAR f, u;
+ collect heap garbage;
+ storage (f, u);
+
+ real (f - u) * 1024.0
+END PROC fre;
+
+REAL PROC fre (REAL CONST dummy):
+ fre ("")
+END PROC fre;
+
+REAL PROC fre (INT CONST dummy):
+ fre ("")
+END PROC fre;
+
+(*Inputroutinenen *)
+INT PROC instr (TEXT CONST source, pattern):
+ pos (source, pattern)
+END PROC instr;
+
+INT PROC instr (REAL CONST from, TEXT CONST source, pattern):
+ instr (cint (from), source, pattern)
+END PROC instr;
+
+INT PROC instr (INT CONST from, TEXT CONST source, pattern):
+ pos (source, pattern, from)
+END PROC instr;
+
+TEXT PROC space (REAL CONST len):
+ space (cint (len))
+END PROC space;
+
+TEXT PROC space (INT CONST len):
+ len * " "
+END PROC space;
+
+TEXT PROC time: (* mo *)
+ subtext (time (clock (1) MOD day), 1, 8) (* hh:mm:ss *)
+END PROC time;
+
+REAL PROC timer:
+ clock (0)
+END PROC timer;
+
+REAL PROC arctan (INT CONST x):
+ arctan (real (x))
+END PROC arctan;
+
+REAL PROC cos (INT CONST x):
+ cos (real (x))
+END PROC cos;
+
+REAL PROC sin (INT CONST x):
+ sin (real (x))
+END PROC sin;
+
+REAL PROC tan (INT CONST x):
+ tan (real (x))
+END PROC tan;
+
+REAL PROC exp (INT CONST x):
+ exp (real (x))
+END PROC exp;
+
+REAL PROC ln (INT CONST x):
+ ln (real (x))
+END PROC ln;
+
+REAL PROC floor (INT CONST x):
+ real (x)
+END PROC floor;
+
+REAL PROC sqrt (INT CONST x):
+ sqrt (real (x))
+END PROC sqrt;
+
+END PACKET basic std;
+
+PACKET basic using DEFINES using, (* Autor: Heiko Indenbirken *)
+ clear using, (* Stand: 05.08.1987/rr/mo *)
+ basic text:
+
+
+LET exclamation point = "!",
+ backslash = "\",
+ comercial and = "&",
+ numbersign = "#",
+ plus = "+",
+ minus = "-",
+ asterisk dollar = "**$",
+ asterisk = "**",
+ dollarsign = "$$",
+ comma = ",",
+ point = ".",
+ caret = "^^^^",
+ underscore = "_",
+ blank = " ",
+ nil = "",
+
+ number format chars = "#+-*$.^",
+ format chars = "!\&#+-$*.";
+
+TEXT VAR result, using format :: "", pre format :: "";
+INT VAR using pos :: 0;
+BOOL VAR image used :: FALSE;
+
+PROC using (TEXT CONST format):
+ using format := format;
+ using pos := 0;
+ result := "";
+ image used := TRUE
+
+END PROC using;
+
+PROC clear using:
+ using format := "";
+ image used := FALSE
+END PROC clear using;
+
+TEXT PROC next format:
+ pre format := "";
+ IF using pos = 0
+ THEN ""
+ ELSE search rest of format FI .
+
+search rest of format:
+ WHILE using pos <= length (using format)
+ REP IF at underscore
+ THEN using pos INCR 1;
+ pre format CAT akt char
+ ELIF at format char
+ THEN LEAVE next format WITH pre format
+ ELSE pre format CAT akt char FI;
+ using pos INCR 1
+ PER;
+ using pos := 0;
+ pre format .
+
+at underscore:
+ akt char = underscore .
+
+at format char:
+ pos (format chars, akt char) > 0 CAND
+ evtl double asterisk CAND
+ evtl point with numbersign .
+
+evtl double asterisk:
+ akt char <> asterisk COR next char = asterisk .
+
+evtl point with numbersign:
+ akt char <> point COR next char = numbersign .
+
+akt char: using format SUB using pos .
+next char: using format SUB using pos+1 .
+END PROC next format;
+
+PROC init (TEXT VAR l result):
+ IF using pos = 0
+ THEN using pos := 1;
+ l result := next format;
+ IF using pos = 0
+ THEN errorstop (1005, "USING: kein Format gefunden") FI
+ ELSE l result := "" FI
+
+END PROC init;
+
+TEXT PROC basic text (TEXT CONST string):
+ IF image used
+ THEN using text
+ ELSE string FI .
+
+using text:
+ init (result);
+ result CAT format string;
+ using pos INCR 1;
+ result CAT next format;
+ result .
+
+format string:
+ IF akt char = exclamation point
+ THEN string SUB 1
+ ELIF akt char = backslash
+ THEN given length string
+ ELIF akt char = comercial and
+ THEN string
+ ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI .
+
+given length string:
+ INT VAR len :: 2;
+ FOR using pos FROM using pos+1 UPTO length (using format)
+ REP IF akt char = "\"
+ THEN LEAVE given length string WITH text (string, len) FI;
+ len INCR 1
+ UNTIL akt char <> " "PER;
+ errorstop (1005, "USING-Format fehlerhaft: " + using format);
+ "" .
+
+akt char: using format SUB using pos
+END PROC basic text;
+
+TEXT PROC basic text (INT CONST number):
+ IF image used
+ THEN basic text (real (number))
+ ELSE sign + text (number) FI .
+
+sign:
+ IF number >= 0
+ THEN " "
+ ELSE "" FI .
+
+END PROC basic text;
+
+TEXT PROC basic text (REAL CONST number):
+ IF image used
+ THEN using text
+ ELSE normal text FI .
+
+normal text:
+(* Bei Real Zahlen werden maximal 7 signifikante Stellen ausgegeben, *)
+(* führende und nachfolgende Nullen werden unterdrückt, *)
+(* der Dezimalpunkt wird im Normalformat unterdrückt *)
+ calculate sign;
+ REAL VAR mantissa := round (abs (number), 6-decimal exponent (number));
+ INT CONST exp :: decimal exponent (mantissa);
+
+ IF mantissa = 0.0
+ THEN result := " 0"
+ ELIF exp > 6 OR exp < -7 OR (exp < 0 AND more than 7 signifikant digits)
+ THEN scientific notation
+ ELIF exp < 0
+ THEN short negative notation
+ ELSE short positive notation FI;
+ result .
+
+more than 7 signifikant digits:
+ REAL VAR signifikant := mantissa;
+ set exp (7+exp, signifikant);
+ frac (signifikant) <> 0.0 .
+
+calculate sign:
+ IF number >= 0.0
+ THEN result := " "
+ ELSE result := "-" FI .
+
+scientific notation:
+ set exp (0, mantissa);
+ result CAT non zero (text (mantissa, 8, 6));
+
+ IF exp < 0
+ THEN result CAT "E-"
+ ELSE result CAT "E+" FI;
+
+ IF abs (exp) > 9
+ THEN result CAT text (abs (exp))
+ ELSE result CAT "0";
+ result CAT text (abs (exp))
+ FI .
+
+short positive notation:
+ result CAT non zero (text (mantissa, 8, 6-exp));
+ IF (result SUB LENGTH result) = "."
+ THEN delete char (result, LENGTH result) FI .
+
+short negative notation:
+ result CAT non zero (subtext (text (abs (mantissa), 9, 7), 2)).(* F13/rr *)
+
+using text:
+ init (result);
+ result CAT format number (subformat, number);
+ result CAT next format;
+ result .
+
+subformat:
+ INT VAR from :: using pos, to :: last format char;
+ subtext (using format, from, to) .
+
+last format char:
+ FOR using pos FROM using pos+1 UPTO length (using format)
+ REP IF non format char
+ THEN LEAVE last format char WITH using pos-1 FI
+ PER;
+ using pos := 0;
+ length (using format) .
+
+non format char:
+ IF (using format SUB using pos) = comma
+ THEN (using format SUB (using pos+1)) <> point
+ ELSE pos (numberformat chars, using format SUB using pos) = 0 FI .
+
+END PROC basic text;
+
+TEXT PROC non zero (TEXT CONST text):
+ INT VAR i;
+ FOR i FROM length (text) DOWNTO 2
+ REP UNTIL (text SUB i) <> "0" PER;
+ subtext (text, 1, i)
+END PROC non zero;
+
+TEXT PROC format number (TEXT CONST format, REAL CONST number):
+ IF no digit char
+ THEN errorstop (1005, "USING-Format fehlerhaft: " + using format); ""
+ ELIF exponent found
+ THEN exponent format
+ ELSE normal format FI .
+
+no digit char:
+ pos (format, numbersign) = 0 AND
+ pos (format, asterisk) = 0 AND
+ pos (format, dollarsign) = 0 .
+
+exponent found:
+ INT CONST exponent pos := pos (format, caret);
+ exponent pos > 0 .
+
+exponent format:
+ IF leading plus
+ THEN plus or minus + exponent field (subtext (format, 2), number, exponent pos-1)
+ ELIF trailing plus
+ THEN exponent field (format, number, exponent pos) + plus or minus
+ ELIF trailing minus
+ THEN exponent field (format, number, exponent pos) + nil or minus
+ ELSE blank or minus + exponent field (subtext (format, 2), number, exponent pos-1) FI .
+
+normal format:
+ IF leading numbersign
+ THEN number field (format, number, "", " ")
+ ELIF leading point
+ THEN number field (format, number, "", " ")
+ ELIF leading plus
+ THEN number field (format, abs (number), plus or minus, " ")
+ ELIF leading asterisk dollar
+ THEN number field (format, number, "$", "*")
+ ELIF leading asterisk
+ THEN number field (format, number, "", "*")
+ ELIF leading dollarsign
+ THEN number field (format, number, "$", " ")
+ ELSE errorstop (1005, "USING-Format fehlerhaft: " + using format); "" FI .
+
+leading numbersign: (format SUB 1) = numbersign .
+leading point: (format SUB 1) = point .
+leading plus: (format SUB 1) = plus .
+leading asterisk dollar: subtext (format, 1, 3) = asterisk dollar .
+leading asterisk: subtext (format, 1, 2) = asterisk .
+leading dollarsign: subtext (format, 1, 2) = dollarsign .
+
+trailing minus: (format SUB LENGTH format) = minus .
+trailing plus: (format SUB LENGTH format) = plus .
+
+plus or minus: IF number < 0.0 THEN minus ELSE plus FI .
+nil or minus: IF number < 0.0 THEN minus ELSE nil FI .
+blank or minus: IF number < 0.0 THEN minus ELSE blank FI .
+
+END PROC format number;
+
+TEXT PROC exponent field (TEXT CONST format, REAL CONST value, INT CONST exponent pos):
+ REAL VAR number := abs (value);
+ INT CONST point pos := pos (format, point);
+ calc leading and trailing;
+ INT CONST new exponent :: decimal exponent (value) - leading + 1;
+ IF abs (new exponent) >= 100
+ THEN "%" + mantissa + "E" + null text (new exponent, 4)
+ ELSE mantissa + exponent
+ FI.
+
+calc leading and trailing:
+ INT VAR leading, trailing;
+ IF point pos = 0
+ THEN leading := exponent pos-1;
+ trailing := 0
+ ELSE leading := point pos-1;
+ trailing := exponent pos-point pos-1
+ FI .
+
+mantissa:
+ set exp (leading - 1, number);
+ IF point pos = 0
+ THEN subtext (text (number, leading+1, 0), 1, leading)
+ ELSE subtext (text (number, leading+trailing+2, trailing), 2) FI .
+
+exponent:
+ "E" + null text (new exponent, 3) .
+
+END PROC exponent field;
+
+TEXT PROC number field (TEXT CONST format, REAL CONST value,
+ TEXT CONST pretext, lead char):
+ INT CONST point pos :: pos (format, point);
+ calc fraction;
+ calc digits;
+ calc commata if necessary;
+ fill with lead chars and sign .
+
+calc fraction:
+ INT VAR fraction :: 0, i;
+ FOR i FROM point pos+1 UPTO length (format)
+ WHILE (format SUB i) = numbersign
+ REP fraction INCR 1 PER .
+
+calc digits:
+ TEXT VAR valuetext;
+ IF point pos = 0
+ THEN valuetext := digits (abs (value), 0, TRUE);
+ delete char (valuetext, length (valuetext))
+ ELSE valuetext := digits (abs (value), fraction, point pos <> 1) FI .
+
+calc commata if necessary:
+ IF comma before point
+ THEN insert commata FI .
+
+comma before point:
+ point pos > 0 CAND (format SUB point pos-1) = comma .
+
+insert commata:
+ i := pos (valuetext, point)-3;
+ WHILE i > 1 CAND (valuetext SUB i) <> " "
+ REP insert char (valuetext, ",", i);
+ i DECR 3
+ PER .
+
+fill with lead chars and sign:
+ IF trailing minus
+ THEN fillby (pretext + valuetext, length (format)-1, lead char) + nil or minus
+ ELIF trailing plus
+ THEN fillby (pretext + valuetext, length (format)-1, lead char) + plus or minus
+ ELIF value < 0.0
+ THEN fillby (pretext + minus + valuetext, length (format), lead char)
+ ELSE fillby (pretext + valuetext, length (format), lead char) FI .
+
+
+plus or minus: IF value < 0.0 THEN minus ELSE plus FI .
+nil or minus: IF value < 0.0 THEN minus ELSE nil FI .
+trailing minus: (format SUB LENGTH format) = minus .
+trailing plus: (format SUB LENGTH format) = plus .
+END PROC numberfield;
+
+TEXT PROC null text (INT CONST n, digits):
+ TEXT VAR l result := text (abs (n), digits);
+ IF n < 0
+ THEN replace (l result, 1, "-")
+ ELSE replace (l result, 1, "+") FI;
+ change all (l result, " ", "0");
+ l result .
+END PROC null text;
+
+TEXT PROC fillby (TEXT CONST source, INT CONST format, TEXT CONST with):
+ IF differenz >= 0
+ THEN differenz * with + source
+ ELSE "%" + source FI .
+
+differenz: format - length (source) .
+END PROC fillby;
+
+TEXT PROC digits (REAL CONST value, INT CONST frac, BOOL CONST null):
+ IF decimal exponent (value) < 0
+ THEN TEXT VAR l result := text (value, frac+2, frac);
+
+ IF null AND first char <> "0"
+ THEN replace (l result, 1, "0");
+ l result
+ ELIF (NOT null AND first char = "0") OR first char = " "
+ THEN subtext (l result, 2)
+ ELSE l result FI
+ ELSE text (value, decimal exponent (value)+frac+2, frac) FI .
+
+first char:
+ (l result SUB 1) .
+
+END PROC digits;
+
+TEXT PROC right (TEXT CONST msg, INT CONST len):
+ IF length (msg) >= len
+ THEN subtext (msg, 1, len)
+ ELSE (len - length (msg)) * " " + msg FI
+
+END PROC right;
+
+END PACKET basic using;
+
+PACKET basic output (* Autor: R. Ruland *)
+ (* Stand: 28.08.1987/rr/mo *)
+ DEFINES basic page,
+ width,
+ init output,
+ basic out,
+ basic write,
+ tab,
+ next zone,
+ next line,
+ next page,
+ cursor x pos,
+ pos,
+ csrlin,
+ l pos,
+ switch to printout file,
+ switch back to old sysout state:
+
+LET zone width = 16; (* sd.ddddddEsdddb (s = sign, d = digit, b = blank) *)
+LET printfile name = "BASIC LPRINT OUTPUT";
+
+INT VAR screen width, x cursor, y cursor, line no;
+BOOL VAR paging := FALSE, first time,
+ in lprint; (* mo *)
+TEXT VAR buffer, output line, last sysout file, old sysout, char;
+
+PROC basic page (BOOL CONST status):
+
+ paging := status
+
+END PROC basic page;
+
+BOOL PROC basic page: paging END PROC basic page;
+
+
+PROC width (INT CONST max):
+
+ IF max < 0
+ THEN errorstop (1005, "WIDTH: negatives Angabe: " + text (max))
+ ELIF max = 0
+ THEN screen width := 1
+ ELSE screen width := max
+ FI;
+ last sysout file := "";
+
+END PROC width;
+
+INT PROC width : screen width END PROC width;
+
+
+PROC init output:
+
+ clear using;
+ width (max (1, x size));
+ line no := 1;
+ output line := "";
+ first time := TRUE;
+ in lprint := FALSE
+
+END PROC init output;
+
+
+PROC basic out (INT CONST i): bas out (basic text (i) + " ") END PROC basic out;
+
+PROC basic out (REAL CONST r): bas out (basic text (r) + " ") END PROC basic out;
+
+PROC basic out (TEXT CONST t): bas out (basic text (t)) END PROC basic out;
+
+PROC basic write (INT CONST i): bas out (basic text (i)) END PROC basic write;
+
+PROC basic write (REAL CONST r): bas out (basic text (r)) END PROC basic write;
+
+PROC basic write (TEXT CONST t): bas out (basic text ("""" + t + """")) END PROC basic write;
+
+
+PROC bas out (TEXT CONST msg):
+
+ get cursor;
+ IF length (msg) > free
+ THEN IF first time
+ THEN first time := FALSE;
+ next line;
+ bas out (msg);
+ ELSE buffer := subtext (msg, 1, free);
+ IF sysout = ""
+ THEN out (buffer)
+ ELSE sysout write (buffer)
+ FI;
+ next line;
+ buffer := subtext (msg, free + 1);
+ bas out (buffer);
+ FI;
+ ELSE first time := TRUE;
+ IF sysout = ""
+ THEN out (msg)
+ ELSE sysout write (msg)
+ FI;
+ FI;
+
+ . free : screen width - x cursor + 1
+
+END PROC bas out;
+
+
+PROC tab (INT CONST n):
+
+ get cursor;
+ IF n <= 0
+ THEN tab position out of range
+ ELIF n > screen width
+ THEN tab (n MOD screen width);
+ ELIF x cursor > n
+ THEN next line;
+ tab (n);
+ ELIF sysout = ""
+ THEN cursor (n, y cursor);
+ ELSE buffer := (n - x cursor) * " ";
+ sysout write (buffer)
+ FI;
+
+ . tab position out of range :
+ IF x cursor <> 1 THEN next line FI;
+ write ("WARNUNG : TAB-Position <= 0");
+ next line;
+
+END PROC tab;
+
+
+PROC next zone:
+
+ get cursor;
+ IF x cursor > screen width - zone width
+ THEN next line;
+ ELIF sysout = ""
+ THEN free TIMESOUT " ";
+ ELSE buffer := free * " ";
+ sysout write (buffer)
+ FI;
+
+ . free : ((x cursor - 1) DIV zone width + 1) * zone width - x cursor + 1
+
+END PROC next zone;
+
+
+PROC next line :
+
+ IF sysout = ""
+ THEN next line on screen
+ ELSE line;
+ write (""); (* generates new record *)
+ output line := "";
+ FI;
+
+ . next line on screen:
+ line no INCR 1;
+ IF paging CAND line no > y size
+ THEN IF in last line
+ THEN warte;
+ ELSE out (""13""10"");
+ line no := y cursor + 1;
+ FI;
+ ELIF NOT paging
+ THEN char := incharety;
+ IF char <> ""
+ THEN IF char = "+"
+ THEN paging := TRUE
+ ELSE type (char)
+ FI
+ FI;
+ out (""13""10"")
+ ELSE out (""13""10"")
+ FI
+
+ . in last line :
+ get cursor;
+ y cursor = y size
+
+ . warte :
+ cursor (x size - 2, y size);
+ out (">>");
+ inchar (char);
+ IF char = ""13""
+ THEN next page
+ ELIF char = ""10""
+ THEN out (""8""8" "13""10"")
+ ELIF char = ""27""
+ THEN clear editor buffer;
+ errorstop (1, "")
+ ELIF char = "-"
+ THEN out (""8""8" "13""10"");
+ line no := 1;
+ paging := FALSE;
+ ELSE out (""8""8" "13""10"");
+ line no := 1;
+ FI;
+
+ . clear editor buffer:
+ REP UNTIL get charety = "" PER;
+
+END PROC next line;
+
+
+PROC next page:
+
+ IF sysout = ""
+ THEN out (""1""4"")
+ ELSE line
+ FI;
+ clear using;
+ line no := 1;
+ output line := "";
+
+END PROC next page;
+
+
+INT PROC pos (REAL CONST dummy): (* mo *)
+
+ cursor x pos
+
+END PROC pos;
+
+
+INT PROC pos (INT CONST dummy): (* mo *)
+
+ cursor x pos
+
+END PROC pos;
+
+
+INT PROC cursor x pos :
+
+ get cursor;
+ x cursor
+
+END PROC cursor x pos;
+
+
+INT PROC csrlin: (* mo *)
+
+ get cursor;
+ y cursor
+
+END PROC csrlin;
+
+
+PROC get cursor :
+
+ IF sysout = ""
+ THEN get cursor (x cursor, y cursor);
+ ELSE x cursor := LENGTH output line + 1;
+ FI;
+
+END PROC get cursor;
+
+
+INT PROC l pos (REAL CONST dummy): (* mo *)
+
+ l pos (0)
+
+END PROC l pos;
+
+
+INT PROC l pos (INT CONST dummy): (* mo *)
+
+ INT VAR lprint position :: 1;
+ IF exists (printfile name)
+ THEN disable stop;
+ FILE VAR printfile :: sequential file (modify, printfile name);
+ IF lines (printfile) > 0
+ THEN to line (printfile, lines (printfile));
+ lprint position := len (printfile) + 1
+ FI;
+ output (printfile)
+ FI;
+ lprint position
+
+END PROC l pos;
+
+
+PROC switch to printout file: (* mo *)
+
+ in lprint := TRUE;
+ old sysout := sysout;
+ careful sysout (printfile name);
+
+END PROC switch to printout file;
+
+
+PROC switch back to old sysout state: (* mo *)
+
+ IF in lprint
+ THEN careful sysout (old sysout);
+ in lprint := FALSE
+ FI
+
+END PROC switch back to old sysout state;
+
+
+PROC sysout write (TEXT CONST string):
+ check sysout;
+ write (string);
+ output line CAT string.
+
+check sysout:
+ IF sysout <> last sysout file
+ THEN careful sysout (sysout)
+ FI.
+
+END PROC sysout write;
+
+
+PROC careful sysout (TEXT CONST new sysout): (* mo *)
+
+IF new sysout <> ""
+ THEN disable stop;
+ FILE VAR outfile :: sequential file (modify, new sysout);
+ max line length (outfile, screen width);
+ last sysout file := sysout;
+ IF lines (outfile) > 0
+ THEN to line (outfile, lines (outfile));
+ read record (outfile, output line);
+ delete record (outfile)
+ ELSE output line := ""
+ FI;
+ sysout (new sysout);
+ write (output line);
+ ELSE sysout ("")
+FI
+
+END PROC careful sysout;
+
+END PACKET basic output;
+
+
+PACKET basic input (* Autor: R. Ruland *)
+ (* Stand: 27.10.1987/rr/mo *)
+
+ DEFINES init input,
+ read input,
+ check input,
+ assign input,
+ assign input line,
+ input ok,
+ input eof:
+
+
+LET comma = ",",
+ quote = """",
+
+ wrong type = 1,
+ insufficient data = 2,
+ too much data = 3,
+ overflow = 4,
+
+ int overflow = 4,
+ real overflow = 6;
+
+INT VAR input line pos, input error no;
+BOOL VAR on terminal;
+TEXT VAR input line :: "", previous input line := "", input value;
+
+. first quote found : (input value SUB 1) = quote
+.;
+
+PROC init input :
+
+ input error no := 0;
+ input line pos := 0;
+ input line := "";
+ previous input line := "";
+
+END PROC init input;
+
+
+PROC read input (BOOL CONST cr lf, TEXT CONST msg, BOOL CONST question mark):
+
+ on terminal := sysout <> "" AND sysin = "";
+ check input error;
+ out string (msg);
+ IF question mark THEN out string ("? ") FI;
+ IF sysin <> ""
+ THEN getline (input line);
+ ELSE editget input line;
+ FI;
+ out string (input line);
+ IF crlf THEN out line FI;
+ input line pos := 0;
+ input error no := 0;
+
+ . check input error :
+ IF input error no = 0
+ THEN input line := "";
+ ELSE IF sysin = ""
+ THEN BOOL CONST old basic page := basic page;
+ basic page (FALSE);
+ IF cursor x pos <> 1 THEN next line FI;
+ basic out ("?Eingabe wiederholen ! (" + error text + ")");
+ next line;
+ basic page (old basic page);
+ ELSE errorstop (1080,"INPUT-Fehler (" + error text +
+ ") : >" + input line + "<");
+ FI;
+ FI;
+
+ . error text :
+ SELECT input error no OF
+ CASE wrong type : "falscher Typ"
+ CASE insufficient data : "zu wenig Daten"
+ CASE too much data : "zu viele Daten"
+ CASE overflow : "Überlauf"
+ OTHERWISE : ""
+ END SELECT
+
+ . editget input line :
+ TEXT VAR exit char;
+ INT VAR x, y;
+ get cursor (x, y);
+ REP IF width - x < 1
+ THEN out (""13""10"");
+ get cursor (x, y)
+ FI;
+ editget (input line, max text length, width - x, "", "k", exit char);
+ cursor (x, y);
+ IF exit char = ""27"k"
+ THEN input line := previous input line;
+ ELSE previous input line := input line;
+ LEAVE editget input line;
+ FI;
+ PER;
+
+END PROC read input;
+
+
+PROC out string (TEXT CONST string) :
+
+ basic out (string);
+ IF on terminal THEN out (string) FI;
+
+END PROC out string;
+
+
+PROC out line :
+
+ next line;
+ IF on terminal THEN out (""13""10"") FI;
+
+END PROC out line;
+
+
+BOOL PROC check input (INT CONST type) :
+
+ get next input value;
+ input value := compress (input value);
+ set conversion (TRUE);
+ SELECT type OF
+ CASE 1 : check int input
+ CASE 2 : check real input
+ CASE 3 : check text input
+ END SELECT;
+ IF NOT last conversion ok THEN input error no := wrong type FI;
+ input error no = 0
+
+ . check int input :
+ IF input value <> ""
+ THEN disable stop;
+ INT VAR help int value;
+ help int value := int (input value);
+ IF is error CAND error code = int overflow
+ THEN clear error;
+ input error no := overflow;
+ FI;
+ enable stop;
+ FI;
+
+ . check real input :
+ IF input value <> ""
+ THEN disable stop;
+ REAL VAR help real value;
+ help real value := val (input value);
+ IF is error CAND (error code = real overflow
+ OR error code = int overflow) (* <-- Aufgrund eines Fehlers in 'real' *)
+ THEN clear error;
+ input error no := overflow;
+ FI;
+ enable stop;
+ FI;
+
+ . check text input :
+ (* IF input value = "" THEN input error no := wrong type FI; *)
+ IF NOT is quoted string CAND quote found
+ THEN input error no := wrong type
+ FI;
+
+ . is quoted string :
+ first quote found CAND last quote found
+
+ . last quote found :
+ (input value SUB LENGTH input value) = quote
+
+ . quote found :
+ pos (input value, quote) > 0
+
+END PROC check input;
+
+
+PROC assign input (INT VAR int value) :
+
+ get next input value;
+ int value := int (input value);
+
+END PROC assign input;
+
+PROC assign input (REAL VAR real value) :
+
+ get next input value;
+ real value := val (input value);
+
+END PROC assign input;
+
+PROC assign input (TEXT VAR string value) :
+
+ get next input value;
+ input value := compress (input value);
+ IF first quote found
+ THEN string value := subtext (input value, 2, LENGTH input value -1)
+ ELSE string value := input value
+ FI;
+
+END PROC assign input;
+
+PROC assign input line (TEXT VAR string line) :
+
+ string line := input line;
+
+END PROC assign input line;
+
+
+PROC get next input value : (* F27/rr *)
+
+ IF input line pos > LENGTH input line
+ THEN input value := "";
+ input error no := insufficient data;
+ ELSE IF next non blank char = quote
+ THEN get quoted string
+ ELSE get unquoted string
+ FI;
+ FI;
+
+ . next non blank char :
+ INT CONST next non blank char pos := pos (input line, ""33"", ""255"", input line pos + 1);
+ input line SUB next non blank char pos
+
+ . get quoted string :
+ INT CONST quote pos := pos (input line, quote, next non blank char pos + 1);
+ IF quote pos = 0
+ THEN input value := subtext (input line, next non blank char pos);
+ input line pos := LENGTH input line + 1;
+ input error no := wrong type;
+ ELSE input value := subtext (input line, next non blank char pos, quote pos);
+ input line pos := pos (input line, ""33"", ""255"", quote pos + 1);
+ IF input line pos = 0
+ THEN input line pos := LENGTH input line + 1;
+ ELIF (input line SUB input line pos) <> comma
+ THEN input error no := wrong type;
+ input line pos DECR 1;
+ FI;
+ FI;
+
+ . get unquoted string :
+ INT VAR comma pos := pos (input line, comma, input line pos + 1);
+ IF comma pos = 0
+ THEN input value := subtext (input line, input line pos + 1);
+ input line pos := LENGTH input line + 1;
+ ELSE input value := subtext (input line, input line pos + 1, comma pos - 1);
+ input line pos := comma pos;
+ FI;
+
+END PROC get next input value;
+
+
+BOOL PROC input ok:
+
+ IF input line pos <= LENGTH input line
+ THEN input error no := too much data FI;
+ input line pos := 0;
+ input error no = 0
+
+END PROC input ok;
+
+BOOL PROC input eof: input line = "" END PROC input eof;
+
+
+END PACKET basic input;
+
+PACKET basic std using io (* Autor: R. Ruland *)
+ (* Stand: 26.10.87/rr/mo *)
+
+ DEFINES init rnd:
+
+
+PROC init rnd:
+
+ REAL VAR init;
+ REP read input (TRUE, "Startwert des Zufallszahlengenerators ? ", FALSE);
+ UNTIL check input (2) CAND input ok PER; (* F24/rr *)
+ assign input (init);
+ init rnd (init);
+
+END PROC init rnd;
+
+
+END PACKET basic std using io;
+
diff --git a/lang/basic/1.8.7/src/eumel coder 1.8.1 b/lang/basic/1.8.7/src/eumel coder 1.8.1
new file mode 120000
index 0000000..5fead18
--- /dev/null
+++ b/lang/basic/1.8.7/src/eumel coder 1.8.1
@@ -0,0 +1 @@
+../../../../system/eumel-coder/1.8.1/src/eumel coder 1.8.1 \ No newline at end of file
diff --git a/lang/basic/1.8.7/src/eumel0 codes b/lang/basic/1.8.7/src/eumel0 codes
new file mode 100644
index 0000000..226014c
--- /dev/null
+++ b/lang/basic/1.8.7/src/eumel0 codes
Binary files differ
diff --git a/lang/basic/1.8.7/src/gen.BASIC b/lang/basic/1.8.7/src/gen.BASIC
new file mode 100644
index 0000000..9690ae6
--- /dev/null
+++ b/lang/basic/1.8.7/src/gen.BASIC
@@ -0,0 +1,80 @@
+(**************************************************************************)
+(* *)
+(* Generatorprogramm zur Installation des EUMEL-BASIC-Systems *)
+(* *)
+(* Autor: Heiko Indenbirken *)
+(* Überarbeitet von: Michael Overdick *)
+(* *)
+(* Stand: 27.08.1987 *)
+(* *)
+(**************************************************************************)
+
+LET coder name = "eumel coder 1.8.1";
+
+show headline;
+from archive ("BASIC.1", (coder name & "eumel0 codes") - all);
+from archive ("BASIC.2",
+ ("BASIC.Runtime" & "BASIC.Administration" & "BASIC.Compiler") - all);
+set status;
+insert ("eumel coder 1.8.1");
+insert ("BASIC.Runtime");
+insert ("BASIC.Administration");
+insert ("BASIC.Compiler");
+forget (coder name & "BASIC.Runtime"
+ & "BASIC.Administration" & "BASIC.Compiler" & "gen.BASIC");
+restore status;
+show end .
+
+show headline:
+ page;
+ putline (" "15"Einrichten des EUMEL-BASIC-Systems "14"");
+ line .
+
+set status:
+ BOOL VAR old check := check,
+ old warnings := warnings,
+ old command dialogue := command dialogue;
+ check off;
+ warnings off;
+ command dialogue (FALSE).
+
+restore status:
+ IF old check THEN do ("check on") ELSE do ("check off") FI;
+ IF old warnings THEN warnings on FI;
+ command dialogue (old command dialogue).
+
+show end:
+ line (2);
+ putline (" "15"BASIC-System installiert "14"");
+ line .
+
+PROC from archive (TEXT CONST name, THESAURUS CONST files):
+ IF highest entry (files) > 0
+ THEN ask for archive;
+ archive (name);
+ fetch (files, archive);
+ release (archive);
+ putline ("Archiv abgemeldet !")
+ FI .
+
+ask for archive:
+ line;
+ IF no ("Archiv """ + name + """ eingelegt")
+ THEN errorstop ("Archive nicht bereit") FI .
+
+END PROC from archive;
+
+THESAURUS OP & (TEXT CONST left, right):
+ THESAURUS VAR result := empty thesaurus;
+ insert (result, left);
+ insert (result, right);
+ result
+END OP &;
+
+THESAURUS OP & (THESAURUS CONST left, TEXT CONST right):
+ THESAURUS VAR result := left;
+ insert (result, right);
+ result
+END OP &;
+
+