path: root/lang/basic/1.8.7/src/BASIC.Compiler

(***************************************************************************)
(*                                                                         *)
(*           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