TurboModula2/src/compiler/SCANNER.MOD

(* Renamed for readability. Semantics unchanged. Original identifiers: see docs/compiler/ + src/compiler/RENAME-MAP.md. *)
IMPLEMENTATION MODULE Scanner;
IMPORT Compiler, Files, Texts, ComLine, Loader, Doubles, Errors, SymTab, CodeGen;
FROM SYSTEM IMPORT ADR, MOVE, CODE, TSIZE, BYTE, OVERFLOW, REALOVERFLOW;
FROM STORAGE IMPORT ALLOCATE,MARK,RELEASE;

VAR withSave: RecordPtr;
    tokLen: CARDINAL;

CONST FREEMARKER = 3AE3H;
CONST EOT = 032C; DEL = 177C;
CONST LINEFEED = 012C; TAB = 011C; CR = 015C;

VAR stackLimit [0316H]: ADDRESS;
VAR buffer  [0080H]: ARRAY [0..127] OF CHAR;
VAR bufIndex[006CH]: CARDINAL;
VAR filePos [006EH]: CARDINAL;
VAR column  [0070H]: CARDINAL;
VAR flag    [0072H]: CARDINAL;

CONST EXPECTED = " expected, but ";

(* $[+ remove procedure names *)

PROCEDURE ScanErr(c: CARDINAL);
BEGIN
  Errors.ReportError(c);
END ScanErr;

PROCEDURE ChangeEx(VAR f: ARRAY OF CHAR; e: Ext; x: BOOLEAN);
VAR i: CARDINAL;
BEGIN
  i := 0;
  WHILE (i < HIGH(f) - 3) AND (f[i] <> 0C) AND (f[i] <> '.') DO
    INC(i)
  END;
  IF x OR (f[i] <> '.') THEN
    f[i] := '.';
    MOVE(ADR(e), ADR(f[i+1]), 3);
  END;
END ChangeEx;

PROCEDURE EnterMod(m: ARRAY OF CHAR; k: CARDINAL): CARDINAL;
VAR i: CARDINAL;
    ptr : POINTER TO SymTab.Symbol;
BEGIN
  i := 0;
  WHILE (i < SymTab.moduleCount) AND (SymTab.moduleTable^[i].name <> m) DO
    INC(i)
  END; 
  ptr := ADR(SymTab.moduleTable^[i]);
  IF i < SymTab.moduleCount THEN
    IF ptr^.word <> k THEN Errors.ReportErrorWithText(12, ptr^.name) END;
  ELSE
    IF i > 15 THEN ScanErr(84) END;
    ptr^.name := m;
    ptr^.word := k;
    INC(SymTab.moduleCount);
  END;
  RETURN i
END EnterMod;

PROCEDURE Allocate(VAR a:ADDRESS; n:CARDINAL); (* was in Z80 code *)
BEGIN
  ALLOCATE(a, n);
END Allocate;

PROCEDURE GetStack(VAR m: ADDRESS);
BEGIN
  m := stackLimit - 60;
END GetStack;

PROCEDURE CheckStk(m: ADDRESS);
BEGIN 
  stackLimit := m + 60;
  m^ := FREEMARKER;
END CheckStk;

(* proc 22: find identifier in keyword list *)
PROCEDURE FindIden(l: List; i: ADDRESS; c: BOOLEAN): RecordPtr;
(* original was in Z80 code *)
VAR current: T1;
BEGIN
  current := l^.first;
  WHILE current <> NIL DO
    IF StrCmp(i, current^.link1, c) THEN 
      RETURN ADDRESS(current)
    END;
    current := current^.link0;
  END;
  RETURN NIL;
END FindIden;

(* StrCmp: original proc23 is hand-tuned stack machine code (zero stores;
   running pointers live on the M-stack, sizes shared via dup) that no
   straight v1.00 Modula-2 source reproduces (proven by exhaustive probes:
   INC/+/deref each fail on some operand type; v1.00 always uses memory
   for loop state - see F1/S3 probes). The M-code algorithm, fully decoded:
   - c=TRUE: LOOP { ch1=*a++; ch2=*b++; folded=((ch1 XOR ch2) AND 0DFH);
       IF folded#{} THEN RETURN FALSE END; IF ch1=0C THEN RETURN TRUE END }
     (fold via BITSET `/`+`*`; the 0DFH mask also hides the high byte of
     the 16-bit word fetch, so the compare is correct)
   - c=FALSE: unbounded NUL-terminated compare via string_comp.
   This clean version implements exactly that (locals instead of M-stack
   temps). NOTE: the decompiled ancestor dropped the c=TRUE branch entirely
   ("removed caseInsensitive comparison"); it is restored here. *)
TYPE ByteVec = POINTER TO ARRAY [0..32767] OF CHAR;
PROCEDURE StrCmp(a, b: ADDRESS; c: BOOLEAN):BOOLEAN;
VAR x, y: ByteVec;
    ch1, ch2: CHAR;
BEGIN
  x := a; y := b;
  IF c THEN
    LOOP
      ch1 := x^[0]; x := ADR(x^[1]);
      ch2 := y^[0]; y := ADR(y^[1]);
      IF ((BITSET(ORD(ch1)) / BITSET(ORD(ch2))) * BITSET{0,1,2,3,4,6,7})
         = BITSET{} THEN
        IF ch1 = 0C THEN RETURN TRUE END;
      ELSE RETURN FALSE END;
    END;
  ELSE
    WHILE x^[0] = y^[0] DO
      IF x^[0] = 0C THEN RETURN TRUE END;
      x := ADR(x^[1]); y := ADR(y^[1]);
    END;
    RETURN FALSE;
  END;
END StrCmp;

(* StrLen: original proc24 is the same hand-tuned stack-code class (counter
   lives on the M-stack; bound shared; `load-0,dec` = CARDINAL max literal).
   Decoded algorithm: i:=-1; LOOP { INC(i); IF i>bound THEN EXIT END;
   IF s^[i]=0C THEN EXIT END }; IF i=0 THEN i:=1 END; RETURN i.
   Clean version below (memory counter, same semantics incl. min-1 and the
   inclusive bound). Signature follows the original DEF
   (param2: ADDRESS; param1: WORD): callers pass (ADR(s), HIGH(s)). *)
PROCEDURE StrLen(s: ADDRESS; bound: CARDINAL): CARDINAL;
VAR p: ByteVec;
    i: CARDINAL;
BEGIN
  p := s; i := 0;
  WHILE (i <= bound) AND (p^[i] # 0C) DO INC(i) END;
  IF i = 0 THEN RETURN 1 END;
  RETURN i
END StrLen;

PROCEDURE CopyStr(VAR d: ADDRESS; VAR s: ARRAY OF CHAR);
VAR length: CARDINAL;
BEGIN
  length := StrLen(ADR(s), HIGH(s));
  Allocate(d, length+1);
  MOVE(ADR(s), d, length);
END CopyStr;

PROCEDURE NewNode(k:CARDINAL):ADDRESS;
VAR ptr: Compiler.RecordPtr;
BEGIN
  Allocate(ptr, 14);
  ptr^.word4 := k;
  RETURN ptr
END NewNode;

PROCEDURE NewSized(k:CARDINAL):ADDRESS;
VAR ptr: Compiler.RecordPtr;
BEGIN
  IF    k <=  1 THEN Allocate(ptr, 14)
  ELSIF k <=  6 THEN Allocate(ptr, 10)
  ELSIF k <= 11 THEN Allocate(ptr, 12)
  ELSE               Allocate(ptr, 16)
  END;
  ptr^.word4 := k;
  RETURN ptr
END NewSized;

PROCEDURE MakeIden(k: CARDINAL): ADDRESS;
VAR ptr : Compiler.RecordPtr;
BEGIN
  NeedID;
  IF ADDRESS(scopeCur) = SymTab.currentScope THEN Errors.ReportErrorWithText(1, tokBuf) END;
  ptr := NewNode(k);
  CopyStr(ptr^.word1, tokBuf);
  GetSym;
  RETURN ptr
END MakeIden;

PROCEDURE InsertSy(n: SymTab.T1);
BEGIN
  IF FindIden(ADR(SymTab.currentScope^.link1), n^.link1, 9 IN scanOpt) # NIL THEN
    Errors.ReportErrorWithText(1, n^.link1^)
  END;
  n^.link0 := SymTab.currentScope^.link1;
  SymTab.currentScope^.link1 := n;
END InsertSy;

PROCEDURE DeclIden(k: CARDINAL): ADDRESS;
VAR ptr: SymTab.T1;
BEGIN
  ptr := MakeIden(k);
  ptr^.link0 := SymTab.currentScope^.link1;
  SymTab.currentScope^.link1 := ptr;
  RETURN ptr;
END DeclIden;

PROCEDURE OpenScop(a:ADDRESS; b: ADDRESS);
BEGIN
  Allocate(SymTab.currentScope, 14);
  SymTab.currentScope^.w0 := a;
  SymTab.currentScope^.link1 := b;
END OpenScop;

PROCEDURE WritList;
VAR PipeChar[034EH]: CHAR;
BEGIN
  Texts.WriteLn(2);
  IF listing 
  THEN Texts.WriteCard(2, CodeGen.nextEmitPos - codeSize, 4)
  ELSE Texts.SetCol(2, 4)
  END;
  Texts.WriteChar(2, PipeChar);
  Texts.WriteChar(2, ' ')
END WritList;

PROCEDURE EchoChar;
BEGIN
  IF (ORD(curCh) + 1) MOD 256 > 32 THEN Texts.WriteChar(2, curCh); RETURN END;
  IF curCh = LINEFEED THEN column := 0; WritList; RETURN END;
  IF curCh = TAB      THEN 
    REPEAT Texts.WriteChar(2," "); INC(column) UNTIL column MOD 8 = 0;
  ELSIF (curCh < " ") AND (curCh # CR) THEN
    Texts.WriteChar(2, "^");
    Texts.WriteChar(2, CHR(ORD(curCh)+40H))
  END;
END EchoChar;

PROCEDURE Refill;
VAR nbRead: CARDINAL;
BEGIN
  nbRead := Files.ReadBytes(srcFile, ADR(buffer), 128);
  IF nbRead < 128 THEN buffer[nbRead] := EOT END;
  bufIndex := 0;
  NextCh
END Refill;

PROCEDURE InitScan;
BEGIN
  curCh  := ' ';
  column   := 0;
  bufIndex := 128;
  IF 0 IN scanOpt THEN WritList END;
  Files.NoTrailer(srcFile)
END InitScan;

PROCEDURE OpenSrc;
VAR nbRead: CARDINAL;
BEGIN
  IF NOT Files.Open(srcFile, ComLine.inName) THEN HALT END;
  InitScan;
  Files.SetPos(srcFile, LONG((tokPos DIV 128) * 128));
  nbRead   := Files.ReadBytes(srcFile, ADR(buffer), 128);
  bufIndex := tokPos MOD 128;
  filePos  := tokPos;
  GetSym
END OpenSrc;

PROCEDURE NextCh; (* original was in Z80 code *)
VAR ch: CHAR;
BEGIN
  IF bufIndex = 128 THEN Refill
  ELSE
    ch := buffer[bufIndex];
    INC(bufIndex);
    IF ch = EOT THEN curCh := 377C ELSE curCh := ch END;
    INC(filePos);
    IF 0 IN scanOpt THEN
      IF ch >= ' ' THEN
        INC(column);
        IF flag # 0 THEN
          Texts.WriteChar(3, ch);
          RETURN;
        END;
      END;
      EchoChar
    END;
  END;
END NextCh;

PROCEDURE GetSym;
(* $[- keep procedure names *)

  (* proc 35 *)
  PROCEDURE ParseNum;
  VAR intPart: CARDINAL;
  VAR expVal: CARDINAL;
  VAR curDig: CARDINAL;
  VAR prevDig: CARDINAL;
  VAR limit: CARDINAL;
  VAR expAdj: INTEGER;
  VAR negExp: BOOLEAN;
  VAR isDec : BOOLEAN;
  VAR isOctal: BOOLEAN;
  VAR decVal: LONGINT;
  VAR decFull: LONGINT;
  VAR octVal: LONGINT;
  VAR hexVal: LONGINT;
  
  (* $[+ remove procedure names *)
  
    (* proc 36 *)
    PROCEDURE Power10(exp: CARDINAL): REAL;
    VAR i: CARDINAL;
    VAR r: REAL;
    BEGIN
      i := 0;
      r := 1.0;
      REPEAT
        IF ODD(exp) THEN
          CASE i OF
          | 0 : r := r * 1.0E01
          | 1 : r := r * 1.0E02
          | 2 : r := r * 1.0E04
          | 3 : r := r * 1.0E08
          | 4 : r := r * 1.0E16
          | 5 : r := r * 1.0E32
          ELSE RAISE REALOVERFLOW
          END;
        END;
        exp := exp DIV 2;
        INC(i);
      UNTIL exp = 0;
      RETURN r
    END Power10;
  
    PROCEDURE AccumDig;
    VAR digit: CARDINAL;
    BEGIN
      IF tokLen < 128 THEN tokBuf[tokLen] := curCh; INC(tokLen) END;
      NextCh;
      digit := ORD(curCh) - ORD('0');
      IF digit > 9 THEN
        IF digit >= 17 THEN digit := digit - 7 ELSE digit := 16 END;
      END; (* 043C *)
      curDig := digit
    END AccumDig;
  
  (* $[- keep procedure names *)
  BEGIN (* ParseNum *)
    intPart  := 0;
    decVal := LONG(0);
    expAdj  := 0;
    hexVal := decVal;
    octVal := decVal;
    decFull := decVal;
    tokLen:= 0;
    curDig  := ORD(curCh) - ORD('0');
    prevDig  := curDig;
    isOctal := TRUE;
    isDec  := TRUE;
    REPEAT
      IF prevDig > 7 THEN
        isOctal := FALSE;
        IF prevDig > 9 THEN isDec := FALSE END;
      END;
      IF curDig <= 9 THEN
        decFull := decFull * LONG(10) + LONG(curDig);
        IF decFull < 3355443L THEN decVal := decFull ELSE INC(expAdj) END;
        IF curDig <= 7 THEN octVal := octVal * LONG(8) + LONG(curDig) END;
      END; (* 04b1 *)
      IF hexVal <= LONG(65535) THEN hexVal := hexVal * LONG(16) + LONG(curDig) END;
      prevDig := curDig;
      AccumDig;
    UNTIL curDig > 15;
    litType := Compiler.CardType;
    IF curCh = '.' THEN
      AccumDig;
      IF    curCh = '.' THEN curCh := DEL; DEC(tokLen)
      ELSIF curCh = ')' THEN curCh := ']'; DEC(tokLen)
      ELSE
        IF NOT isDec THEN ScanErr(30) END;
        litType := Compiler.RealType;
        WHILE curDig <= 9 DO
          IF decVal < 3355443L THEN
            decVal := decVal * LONG(10) + LONG(curDig);
            DEC(expAdj)
          END; (* 0527 *)
          AccumDig;
        END; (* 052B *)
        IF curDig IN {13, 14} THEN
          IF curDig = 13 THEN litType := Compiler.LongrealType END;
          expVal := 0;
          AccumDig;
          negExp := (curCh = '-');
          IF negExp OR (curCh = '+') THEN AccumDig END;
          IF curDig > 9 THEN ScanErr(30) END;
          REPEAT
            IF expVal < 255 THEN expVal := expVal * 10 + curDig END;
            AccumDig;
          UNTIL curDig > 9;
          IF negExp
          THEN DEC(expAdj, expVal)
          ELSE INC(expAdj, expVal)
          END;
        END; (* 0577 *)
        IF litType = Compiler.RealType THEN
          IF decVal >= 16777216L
          THEN realVal := FLOAT((decVal + 1L) DIV 2L) * 2.0 (* LONG(1)/LONG(2)
             call nodes spiked the v1.00 expression heap (OUT OF MEMORY);
             L-suffixed literals fold to const nodes, identical codegen *)
          ELSE realVal := FLOAT(decVal)
          END;
          IF    expAdj < 0 THEN realVal := realVal / Power10(-expAdj)
          ELSIF expAdj # 0 THEN realVal := realVal * Power10(expAdj)
          END;
        ELSE
          tokBuf[tokLen] := 0C;
          IF NOT Doubles.StrToDouble(tokBuf, lrealVal) THEN ScanErr(74) END;
        END;
      END;
    END; (* 05D4 *)
    IF litType^.word4 # 8 THEN
      IF curCh = 'L' THEN
        AccumDig;
        realVal := REAL(decFull);
        litType := Compiler.LongintType;
      ELSE
        limit := 65535;
        IF curCh = 'H' THEN AccumDig; decVal := hexVal
        ELSE
          IF prevDig IN {11, 12} THEN
            IF NOT isOctal THEN ScanErr(30) END;
            decVal := octVal;
            IF prevDig = 12 THEN litType := Compiler.CharType; limit := 255 END;
          ELSE
            IF NOT isDec OR (prevDig > 9) THEN ScanErr(30) END;
            decVal := decFull;
          END;
        END; (* 062e *)
        IF decVal > LONG(limit) THEN ScanErr(73) END;
        cardVal := CARD(decVal);
      END;
    END; (* 063f *)
    IF charClas^[ORD(curCh)] = 10 THEN ScanErr(30) END;
  EXCEPTION
  | OVERFLOW: ScanErr(73)
  | REALOVERFLOW: 
      IF expAdj >= 0 THEN ScanErr(74) END;
      realVal := REAL(0L);
  END ParseNum;
  
(* $[+ remove procedure names *)
  PROCEDURE SkipComm;
  VAR optIdx: CARDINAL;
  BEGIN
    REPEAT
      REPEAT
        IF curCh = CHR(255) THEN ScanErr(29) END;
        NextCh;
        IF curCh = '(' THEN
          REPEAT NextCh UNTIL curCh # '(';
          IF curCh = '*' THEN SkipComm END; (* recursive call *)
        END;
        IF curCh = '$' THEN
          NextCh;
          optIdx := CARDINAL(BITSET(curCh) * {0,1,2,3,4,6}) - ORD('L');
          IF optIdx <= 15 THEN
            NextCh;
            IF    curCh = '-' THEN EXCL(scanOpt, optIdx)
            ELSIF curCh = '+' THEN INCL(scanOpt, optIdx)
            END;
            IF optIdx = 0 THEN Texts.WriteLn(2) END;
          END;
        END; (* 06c6 *)
      UNTIL curCh = '*';
      REPEAT NextCh UNTIL curCh # '*';
    UNTIL curCh = ')';
  END SkipComm;

  PROCEDURE ScanNext():BOOLEAN; (* original was in Z80 code *)
  VAR j: CARDINAL;
  VAR nextClass: CARDINAL;
  BEGIN
    isLit := FALSE;
    identKd := 7;
    WHILE curCh <= ' ' DO NextCh END;
    tokPos := filePos - 1;
    tokCol := column;
    IF curCh < CHR(128)
    THEN curSym := charClas^[ORD(curCh)]
    ELSE curSym := 0
    END;
    IF curSym = 10 THEN
      j := 0;
      REPEAT
        IF j # 128 THEN tokBuf[j] := curCh; INC(j) END;
        NextCh;
        nextClass := charClas^[ORD(curCh)];
      UNTIL (nextClass # 10) AND (nextClass # 11);
      tokBuf[j] := 0C;
      RETURN TRUE
    END; (* 0730 *)
    RETURN FALSE;
  END ScanNext;

VAR tokDone: BOOLEAN;
    strLen: CARDINAL;
    ignCase: BOOLEAN;
    quote: CHAR;
BEGIN
  REPEAT
    IF ScanNext() THEN
      ignCase := 9 IN scanOpt;
      curSym := keyHash(ADR(tokBuf), CHR(ORD(ignCase))); (* CHR(ORD()) is zero-cost (V3 probe) and value-preserving; satisfies CHAR formal *)
      IF curSym # 0 THEN
        identKd := 7;
        IF ((curSym = 14) OR (curSym = 39)) AND NOT (12 IN scanOpt) THEN
          Errors.AskContinue(2)
        END;
        RETURN
      END; (* 0797 *)
      scopeCur := ADDRESS(SymTab.currentScope);
      REPEAT
        curNode  := FindIden(ADR(scopeCur^.link1), ADR(tokBuf), ignCase);
        IF curNode # NIL THEN
          litType := ADDRESS(curNode^.word2);
          identKd  := curNode^.word4;
          follSet := curNode^.word3;
          RETURN
        END;
        scopeCur := scopeCur^.link0;
      UNTIL scopeCur = NIL;
      identKd := 0;
      RETURN
    END; (* 07BA *)
    tokDone := TRUE;
    CASE curSym OF
    | 0 : ScanErr(31 - ORD(curCh = CHR(255)) * 2)
    | 2 : NextCh;
          IF    curCh = '=' THEN curSym := 27; NextCh
          ELSIF curCh = ')' THEN curSym := 7; NextCh
          END;
    | 3 : NextCh;
          IF    curCh = '.' THEN curSym := 4; NextCh
          ELSIF curCh = ')' THEN curSym := 6; NextCh
          END;
    |11 : isLit := TRUE;
          identKd := 1;
          curSym := 0;
          ParseNum;
          tokBuf[tokLen] := 0C
    |12 : strLen  := 0;
          isLit := TRUE;
          identKd := 1;
          curSym := 0;
          quote  := curCh;
          NextCh;
          WHILE curCh # quote DO
            IF curCh = LINEFEED THEN ScanErr(28) END;
            IF curCh = CHR(255) THEN ScanErr(29) END;
            IF strLen < 128 THEN
              tokBuf[strLen] := curCh;
              INC(strLen);
            END;
            NextCh;
          END; (* 0839 *)
          tokBuf[strLen] := 0C;
          NextCh;
          litType := Compiler.charArrayDesc;
          IF strLen = 1 THEN
            litType := Compiler.CharType;
            cardVal  := ORD(tokBuf[0]);
          END;
    ELSE
          NextCh;
          CASE curSym OF
          | 43:  IF curCh = '*' THEN SkipComm; NextCh; tokDone := FALSE
              ELSIF curCh = '.' THEN curSym := 44; NextCh
              ELSIF curCh = ':' THEN curSym := 45; NextCh
              END;
          | 54:  IF curCh = '=' THEN curSym := 56; NextCh 
              ELSIF curCh = '>' THEN curSym := 53; NextCh
              END;
          | 55:  IF curCh = '=' THEN curSym := 57; NextCh END;
          END;
    END;
  UNTIL tokDone;
END GetSym;

PROCEDURE AcceptSy(s: CARDINAL): BOOLEAN;
BEGIN
  IF curSym = s THEN GetSym; RETURN TRUE END;
  RETURN FALSE
END AcceptSy;

PROCEDURE PushWith;
BEGIN
  IF identKd = 6 THEN
    withSave^.word1 := ADDRESS(curNode^.high);
    withSave^.word0 := ADDRESS(SymTab.currentScope);
    SymTab.currentScope  := ADDRESS(withSave);
    GetSym;
    ExpectSy(3);
    NeedID;
    IF scopeCur # ADDRESS(withSave) THEN Errors.ReportErrorWithText(3, tokBuf) END;
    SymTab.currentScope  := SymTab.currentScope^.w0;
  END;
END PushWith;

PROCEDURE ExpectSy(s:CARDINAL);
VAR expSet: BITSET;
VAR base: CARDINAL;
BEGIN
  IF curSym = s THEN GetSym; RETURN END;
  base := 0;
  expSet := {};
  IF    s >= 51 THEN base := 51
  ELSIF s >= 40 THEN base := 40
  ELSIF s >= 27 THEN base := 27
  ELSIF s >= 13 THEN base := 13
  END;
  expSet := expSet + {s - base};
  Errors.ReportExpectedSet(expSet, base)
END ExpectSy;

PROCEDURE TestSet(s: BITSET);
BEGIN
  IF NOT (curSym IN s) THEN Errors.ReportExpectedSet(s, 0) END;
END TestSet;

PROCEDURE TestR40(s: BITSET);
BEGIN
  IF NOT ((curSym-40) IN s) THEN Errors.ReportExpectedSet(s, 40) END;
END TestR40;

PROCEDURE TestR13(s: BITSET);
BEGIN
  IF NOT ((curSym-13) IN s) THEN Errors.ReportExpectedSet(s, 13) END;
END TestR13;

PROCEDURE NeedID;
BEGIN
  IF (identKd = 7) OR isLit THEN
    Errors.ShowErrorPosition('A');
    Texts.WriteString(3, "Identifier");
    Texts.WriteString(3, EXPECTED);
    Errors.WriteFoundToken;
    Errors.AskEditOrQuit;
  END;
END NeedID;

PROCEDURE ExpectSt(VAR p: ARRAY OF CHAR);
BEGIN
  NeedID;
  IF StrCmp(ADR(tokBuf), ADR(p), 9 IN scanOpt) THEN GetSym; RETURN END;
  Errors.ReportErrorWithText(9, p);
END ExpectSt;

PROCEDURE ExpectKd(k: CARDINAL);
BEGIN
  IF identKd # k THEN
    NeedID;
    IF identKd = 0 THEN Errors.ReportErrorWithText(0, tokBuf) END;
    Errors.ShowErrorPosition('B');
    Errors.WriteKindName(k);
    Texts.WriteString(3, EXPECTED);
    Errors.WriteKindName(identKd);
    Texts.WriteString(3, " found");
    Errors.AskEditOrQuit;
  END;
END ExpectKd;

PROCEDURE Compile;

  (* Z80 proc 40 removed in Reloaded; v1.00 rejects SYSTEM.ADR on simple
     unstructured variables, so this open-array shim recovers the address.
     Proven on hardware: open VAR ARRAY OF WORD accepts any variable, and
     ADR(x) inside is legal (probe ZZ.DEF/MOD). *)
  PROCEDURE VarAddr(VAR x: ARRAY OF WORD): ADDRESS;
  BEGIN
    RETURN ADR(x);
  END VarAddr;

VAR addr: ADDRESS;
    ptr       [006EH]: CARDINAL;
    console   [0072H]: BOOLEAN;
    jmpOpc [0074H]: CARDINAL;
    jmpAddr[0075H]: CARDINAL;

(* $[- keep procedure names *)

BEGIN
  jmpOpc := 0C3H;
  addr      := VarAddr(scanOpt)-6;
  addr      := ADDRESS(addr^) - 4;
  jmpAddr:= addr + CARDINAL(addr^) + 3;
  MARK(addr);
  ptr       := 0;
  console   := (ComLine.outName = "CON:");
  listing  := FALSE;
  tokPos  := 0;
  Allocate(withSave, 14);
  Compiler.OpenSourceAndOutput;
  IF srcFile <> NIL THEN
    Allocate(codeBuf, 4096);
    Loader.Call("COMPILE");
    IF Compiler.nativeCodeRequested THEN
      CheckStk(codeBuf + CodeGen.nextEmitPos);
      IF CodeGen.windowBase <> 0 THEN
        MOVE(codeBuf, codeBuf + CodeGen.windowBase, CodeGen.nextEmitPos - CodeGen.windowBase);
        Files.SetPos(codeFile, LONG(0));
        IF Files.ReadBytes(codeFile, codeBuf, CodeGen.windowBase) <> CodeGen.windowBase THEN
          RAISE Files.EndError
        END;
      END;
      Files.SetPos(codeFile, LONG(0));
      Loader.Call("GENZ80");
    END;
  END;
  Texts.CloseText(Texts.output);
  RELEASE(addr);

EXCEPTION Loader.LoadError:
  Texts.WriteLn(3); (* console *)
  Texts.WriteString(3,"ERROR: CANNOT LOAD OVERLAY");
  Texts.WriteLn(3);
  Files.Delete(codeFile);
  RELEASE(addr)
END Compile;

(* $[+ remove procedure names *)
END Scanner.