m-code-64/Interpreter.mod

IMPLEMENTATION MODULE Interpreter ;

FROM Local IMPORT GetIP, SetIP, GetSP, SetSP, GetFP, GetGP, GetOFP, SetOFP, SetGP ;
FROM Memory IMPORT ReadByte, WriteByte, ReadSlot, WriteSlot,
  ReadWord, WriteWord, CopyBytes, FillBytes, ArenaBase, MaxMem ;
FROM Stack IMPORT Push, Pop, PopBool, PopReal, PushReal, Reserve ;
FROM Instruction IMPORT Fetch, FetchSignedByte, FetchQuad, LoadString,
  ProcedureAddress, Enter, Leave ;
FROM Global IMPORT GetModuleBase, GetModuleProcs, GetCurrentModule,
  SetCurrentModule, FindModuleByBase ;
FROM Console IMPORT Fatal, WriteChar ;
FROM Extended IMPORT Execute ;
FROM StdChans IMPORT StdInChan ;
FROM IOChan IMPORT Look, Skip ;
FROM IOConsts IMPORT ReadResults, endOfLine, endOfInput ;

PROCEDURE PushBool (b: BOOLEAN) ;
BEGIN
  IF b THEN Push (1) ELSE Push (0) END ;
END PushBool ;

PROCEDURE Shl64 (u: LONGCARD; n: CARDINAL) : LONGCARD ;
VAR i: CARDINAL ;
BEGIN
  IF n >= 64 THEN
    RETURN 0 ;
  END ;
  FOR i := 1 TO n DO
    u := u * 2 ;
  END ;
  RETURN u ;
END Shl64 ;

PROCEDURE ShrLog (u: LONGCARD; n: CARDINAL) : LONGCARD ;
VAR i: CARDINAL ;
BEGIN
  IF n >= 64 THEN
    RETURN 0 ;
  END ;
  FOR i := 1 TO n DO
    u := u DIV 2 ;
  END ;
  RETURN u ;
END ShrLog ;

PROCEDURE Mul64 (a, b: LONGCARD) : LONGCARD ;
VAR ah, al, bh, bl, lolo, mid: LONGCARD ;
BEGIN
  ah := a DIV 4294967296 ;
  al := a MOD 4294967296 ;
  bh := b DIV 4294967296 ;
  bl := b MOD 4294967296 ;
  lolo := al * bl ;
  mid := VAL (LONGCARD, VAL (CARDINAL, ah * bl + al * bh)) ;
  RETURN lolo + mid * 4294967296 ;
END Mul64 ;

PROCEDURE Low32 (u: LONGCARD) : CARDINAL ;
BEGIN
  RETURN VAL (CARDINAL, u) ;
END Low32 ;

PROCEDURE BitOp (a, b: LONGCARD; mode: CARDINAL) : LONGCARD ;
VAR res, m: LONGCARD ; p: CARDINAL ; ba, bb: CARDINAL ;
BEGIN
  res := 0 ;
  m := 1 ;
  FOR p := 0 TO 63 DO
    ba := VAL (CARDINAL, (a DIV m) MOD 2) ;
    bb := VAL (CARDINAL, (b DIV m) MOD 2) ;
    IF mode = 0 THEN  (* AND *)
      IF (ba = 1) AND (bb = 1) THEN res := res + m END ;
    ELSIF mode = 1 THEN  (* OR *)
      IF (ba = 1) OR (bb = 1) THEN res := res + m END ;
    ELSE  (* XOR *)
      IF ba # bb THEN res := res + m END ;
    END ;
    m := m * 2 ;
  END ;
  RETURN res ;
END BitOp ;

PROCEDURE ReadLine (dst: LONGCARD) ;
(* SYSTEM service 2 : read one line from the host standard input.
   Characters up to (but not including) the line mark, or end of input,
   are stored at dst; a NUL terminator is appended and the VM stack
   receives the number of bytes read (excluding the terminator).
   An empty line or immediate end of input yields 0. *)
VAR p: LONGCARD ; ch: CHAR ; res: ReadResults ;
    done, over: BOOLEAN ;
BEGIN
  p := dst ;
  done := FALSE ;
  over := FALSE ;
  WHILE NOT done DO
    Look (StdInChan (), ch, res) ;
    IF res = endOfInput THEN
      done := TRUE ;
    ELSIF res = endOfLine THEN
      Skip (StdInChan ()) ;
      done := TRUE ;
    ELSIF over THEN
      Skip (StdInChan ()) ;
    ELSIF p >= VAL (LONGCARD, MaxMem) THEN
      over := TRUE ;
    ELSE
      WriteByte (p, ORD (ch)) ;
      p := p + 1 ;
      Skip (StdInChan ()) ;
    END ;
  END ;
  IF p < VAL (LONGCARD, MaxMem) THEN
    WriteByte (p, 0) ;
    p := p + 1 ;
  END ;
  Push (p - dst - 1) ;
END ReadLine ;

PROCEDURE Service (id, param: LONGCARD) ;
VAR c: CARDINAL ; p: LONGCARD ;
BEGIN
  CASE id OF
  | 0 :  (* EXIT *)
      RETURN ;
  | 1 :  (* write NUL-terminated string at param *)
      p := param ;
      c := ReadByte (p) ;
      WHILE c # 0 DO
        WriteChar (CHR (c)) ;
        p := p + 1 ;
        c := ReadByte (p) ;
      END ;
  | 2 :  (* read line into buffer at param *)
        ReadLine (param) ;
  ELSE
      Fatal ("system: unknown service") ;
  END ;
END Service ;

PROCEDURE Run ;
VAR opc, n, m, tm, lo, hi, nw: CARDINAL ;
    v, w, a, b, p, q, sz, sz2, ssz, t, off, cell, loww, highw, last,
    st, dv, src, dst, first, eot, np, rel, md: LONGCARD ;
    sgn: LONGINT ;
    gl, bl: LONGINT ;
    r1, r2: REAL ;
    i64: LONGCARD ;
    i: LONGCARD ;
    done: BOOLEAN ;
BEGIN
  done := FALSE ;
  LOOP
    opc := Fetch () ;
    CASE opc OF
    | 00H :  (* reserved -> IllegalInstruction *)
        Fatal ("illegal instruction 00H") ;
    | 01H :  (* RAISE : unimplemented *)
        Fatal ("RAISE unimplemented") ;
    | 02H :  (* load_proc_addr u8 *)
        n := Fetch () ;
        Push (ProcedureAddress (GetCurrentModule (), n)) ;
    | 03H .. 07H :  (* load_param n : push FP[op] for params 1..5 *)
        Push (ReadSlot (GetFP () + VAL (LONGCARD, opc) * 8)) ;
    | 08H :  (* load_local_dw i8 *)
        Push (ReadSlot (GetFP () + VAL (LONGCARD, FetchSignedByte ()) * 8)) ;
    | 09H :  (* load_global_dw u8 *)
        Push (ReadSlot (GetGP () + VAL (LONGCARD, Fetch ()) * 8)) ;
    | 0AH :  (* load_stack_dw u8 *)
        p := Pop () ;
        Push (ReadSlot (p + VAL (LONGCARD, Fetch ()) * 8)) ;
    | 0BH :  (* load_extern_dw mod,var *)
        m := Fetch () ;
        Push (ReadSlot (GetModuleBase (m) + VAL (LONGCARD, Fetch ()) * 8)) ;
    | 0CH :  (* load_extern_w nibble *)
        nw := Fetch () ;
        Push (ReadSlot (GetModuleBase (nw DIV 16) + VAL (LONGCARD, nw MOD 16) * 8)) ;
    | 0DH :  (* load_indexed_byte *)
        v := Pop () ; p := Pop () ;
        Push (VAL (LONGCARD, ReadByte (p + v))) ;
    | 0EH :  (* load_indexed_w *)
        v := Pop () ; p := Pop () ;
        Push (ReadSlot (p + v * 8)) ;
    | 0FH :  (* load_indexed_q *)
        v := Pop () ; p := Pop () ;
        Push (ReadSlot (p + v * 8 + 8)) ;
        Push (ReadSlot (p + v * 8)) ;
    | 10H :  (* load_outer : push enclosing frame pointer *)
        Push (GetOFP ()) ;
    | 11H :  (* load_outer_n u8 : walk the display *)
        np := Fetch () ;
        p := GetOFP () ;
        i := 0 ;
        WHILE i < VAL (LONGCARD, np) DO
          p := ReadSlot (p) ;
          i := i + 1 ;
        END ;
        Push (p) ;
    | 12H :  (* LONGREAL/quad sub-opcode dispatch ... *)
        nw := Fetch () ;
        CASE nw OF
        | 0 :  (* load_local_q i8 *)
            sgn := VAL (LONGINT, FetchSignedByte ()) ;
            Push (ReadSlot (GetFP () + (VAL (LONGCARD, sgn) + 1) * 8)) ;
            Push (ReadSlot (GetFP () + VAL (LONGCARD, sgn) * 8)) ;
        | 1 :  (* load_global_q u8 *)
            n := Fetch () ;
            Push (ReadSlot (GetGP () + (VAL (LONGCARD, n) + 1) * 8)) ;
            Push (ReadSlot (GetGP () + VAL (LONGCARD, n) * 8)) ;
        | 2 :  (* load_i_q u8 *)
            n := Fetch () ;
            p := Pop () ;
            Push (ReadSlot (p + (VAL (LONGCARD, n) + 1) * 8)) ;
            Push (ReadSlot (p + VAL (LONGCARD, n) * 8)) ;
        | 3 :  (* load_extern_q mod,var *)
            m := Fetch () ;
            n := Fetch () ;
            Push (ReadSlot (GetModuleBase (m) + (VAL (LONGCARD, n) + 1) * 8)) ;
            Push (ReadSlot (GetModuleBase (m) + VAL (LONGCARD, n) * 8)) ;
        | 4 :  (* store_local_q i8 *)
            sgn := VAL (LONGINT, FetchSignedByte ()) ;
            loww := Pop () ; a := Pop () ;
            WriteSlot (GetFP () + VAL (LONGCARD, sgn) * 8, loww) ;
            WriteSlot (GetFP () + (VAL (LONGCARD, sgn) + 1) * 8, a) ;
        | 5 :  (* store_global_q u8 *)
            n := Fetch () ;
            q := Pop () ;
            WriteSlot (GetGP () + VAL (LONGCARD, n) * 8, q) ;
            q := Pop () ;
            WriteSlot (GetGP () + (VAL (LONGCARD, n) + 1) * 8, q) ;
        | 6 :  (* store_i_q u8 *)
            n := Fetch () ;
            p := Pop () ;
            q := Pop () ;
            WriteSlot (p + VAL (LONGCARD, n) * 8, q) ;
            q := Pop () ;
            WriteSlot (p + (VAL (LONGCARD, n) + 1) * 8, q) ;
        | 7 :  (* store_extern_q mod,var *)
            m := Fetch () ;
            n := Fetch () ;
            q := Pop () ;
            WriteSlot (GetModuleBase (m) + VAL (LONGCARD, n) * 8, q) ;
            q := Pop () ;
            WriteSlot (GetModuleBase (m) + (VAL (LONGCARD, n) + 1) * 8, q) ;
        | 8 :  (* load_indexed_q *)
            v := Pop () ; p := Pop () ;
            Push (ReadSlot (p + v * 8 + 8)) ;
            Push (ReadSlot (p + v * 8)) ;
        | 9 :  (* store_indexed_q *)
            loww := Pop () ; a := Pop () ; v := Pop () ; p := Pop () ;
            WriteSlot (p + v * 8, loww) ;
            WriteSlot (p + v * 8 + 8, a) ;
        | 0AH :  (* quad_fct_leave u8 *)
            n := Fetch () ;
            q := Pop () ;
            Leave (n) ;
            Push (q) ;
        ELSE
            Fatal ("quad sub-opcode illegal") ;
        END ;  (* inner CASE *)
    | 13H .. 17H :  (* store_param n : FP[op] := value *)
        WriteSlot (GetFP () + VAL (LONGCARD, opc) * 8, Pop ()) ;
    | 18H :  (* store_local_dw i8 *)
        WriteSlot (GetFP () + VAL (LONGCARD, FetchSignedByte ()) * 8, Pop ()) ;
    | 19H :  (* store_global_dw u8 *)
        WriteSlot (GetGP () + VAL (LONGCARD, Fetch ()) * 8, Pop ()) ;
    | 1AH :  (* store_stack_dw u8 *)
        p := Pop () ;
        WriteSlot (p + VAL (LONGCARD, Fetch ()) * 8, Pop ()) ;
    | 1BH :  (* store_extern_dw mod,var *)
        m := Fetch () ;
        WriteSlot (GetModuleBase (m) + VAL (LONGCARD, Fetch ()) * 8, Pop ()) ;
    | 1CH :  (* store_extern_w nibble *)
        nw := Fetch () ;
        WriteSlot (GetModuleBase (nw DIV 16) + VAL (LONGCARD, nw MOD 16) * 8, Pop ()) ;
    | 1DH :  (* store_indexed_byte *)
        v := Pop () ; i64 := Pop () ; p := Pop () ;
        WriteByte (p + i64, Low32 (v)) ;
    | 1EH :  (* store_indexed_w *)
        v := Pop () ; i64 := Pop () ; p := Pop () ;
        WriteSlot (p + i64 * 8, v) ;
    | 1FH :  (* store_indexed_q *)
        loww := Pop () ; a := Pop () ; i64 := Pop () ; p := Pop () ;
        WriteSlot (p + i64 * 8, loww) ;
        WriteSlot (p + i64 * 8 + 8, a) ;

    | 20H :  (* dup *)
        v := Pop () ;
        Push (v) ; Push (v) ;
    | 21H :  (* swap *)
        a := Pop () ; b := Pop () ;
        Push (a) ; Push (b) ;
    | 22H .. 2BH :  (* load_local_n *)
        Push (ReadSlot (GetFP () - VAL (LONGCARD, opc MOD 16) * 8)) ;
    | 2CH :  (* load_local i8 *)
        Push (ReadSlot (GetFP () + VAL (LONGCARD, FetchSignedByte ()) * 8)) ;
    | 2DH :  (* load_global u8 *)
        Push (ReadSlot (GetGP () + VAL (LONGCARD, Fetch ()) * 8)) ;
    | 2EH :  (* load_stack u8 *)
        p := Pop () ;
        Push (ReadSlot (p + VAL (LONGCARD, Fetch ()) * 8)) ;
    | 2FH :  (* load_extern mod,var *)
        m := Fetch () ;
        Push (ReadSlot (GetModuleBase (m) + VAL (LONGCARD, Fetch ()) * 8)) ;
    | 30H :  (* copy_block *)
        sz := Pop () ; src := Pop () ; dst := Pop () ;
        CopyBytes (src, dst, sz) ;
    | 31H :  (* copy_string *)
        ssz := Pop () ; sz := Pop () ; src := Pop () ; dst := Pop () ;
        n := 0 ;
        np := 0 ;
        WHILE np < sz DO
          IF ReadByte (src + np) = 0 THEN EXIT END ;
          IF np >= ssz THEN EXIT END ;
          WriteByte (dst + np, ReadByte (src + np)) ;
          np := np + 1 ;
        END ;
    | 32H .. 3BH :  (* store_local_n *)
        WriteSlot (GetFP () - VAL (LONGCARD, opc MOD 16) * 8, Pop ()) ;
    | 3CH :  (* store_local i8 *)
        WriteSlot (GetFP () + VAL (LONGCARD, FetchSignedByte ()) * 8, Pop ()) ;
    | 3DH :  (* store_global u8 *)
        WriteSlot (GetGP () + VAL (LONGCARD, Fetch ()) * 8, Pop ()) ;
    | 3EH :  (* store_stack u8 *)
        p := Pop () ;
        WriteSlot (p + VAL (LONGCARD, Fetch ()) * 8, Pop ()) ;
    | 3FH :  (* store_extern mod,var *)
        m := Fetch () ;
        WriteSlot (GetModuleBase (m) + VAL (LONGCARD, Fetch ()) * 8, Pop ()) ;

    | 40H :
        Execute () ;
    | 41H :  (* load_stack_d0 *)
        p := Pop () ;
        Push (ReadSlot (p)) ;
    | 42H .. 4FH :  (* load_global_n *)
        Push (ReadSlot (GetGP () + VAL (LONGCARD, opc MOD 16) * 8)) ;
    | 50H :  (* end_program *)
        RETURN ;
    | 51H :  (* store_stack_d0 *)
        p := Pop () ;
        WriteSlot (p, Pop ()) ;
    | 52H .. 5FH :  (* store_global_n *)
        WriteSlot (GetGP () + VAL (LONGCARD, opc MOD 16) * 8, Pop ()) ;

    | 60H .. 6FH :  (* load_i_n *)
        p := Pop () ;
        Push (ReadSlot (p + VAL (LONGCARD, opc MOD 16) * 8)) ;
    | 70H .. 7FH :  (* store_i_n *)
        v := Pop () ; p := Pop () ;
        WriteSlot (p + VAL (LONGCARD, opc MOD 16) * 8, v) ;

    | 80H :  (* load_local_addr i8 *)
        Push (GetFP () + VAL (LONGCARD, FetchSignedByte ()) * 8) ;
    | 81H :  (* load_global_addr u8 *)
        Push (GetGP () + VAL (LONGCARD, Fetch ()) * 8) ;
    | 82H :  (* load_stack_addr u8 *)
        p := Pop () ;
        Push (p + VAL (LONGCARD, Fetch ()) * 8) ;
    | 83H :  (* load_extern_addr mod,var *)
        m := Fetch () ;
        Push (GetModuleBase (m) + VAL (LONGCARD, Fetch ()) * 8) ;
    | 84H :  (* proc_leave *)
        Leave (Fetch ()) ;
    | 85H :  (* fct_leave *)
        v := Pop () ;
        Leave (Fetch ()) ;
        Push (v) ;
    | 86H :  (* longfct_leave *)
        q := Pop () ;
        Leave (Fetch ()) ;
        Push (q) ;
    | 87H :  (* asmcode *)
        Fatal ("asmcode unimplemented") ;
    | 88H .. 8BH :  (* leave 0..3, outer return *)
        Leave (128 + (opc MOD 4)) ;
    | 8CH :  (* call_rel u8 *)
        LoadString (Fetch ()) ;
    | 8DH :  (* load_imm_byte *)
        Push (VAL (LONGCARD, Fetch ())) ;
    | 8EH :  (* load_imm_word u64 *)
        Push (FetchQuad ()) ;
    | 8FH :  (* load_imm_quad (16 bytes) : high word first, low on top *)
        a := FetchQuad () ;
        b := FetchQuad () ;
        Push (a) ; Push (b) ;
    | 90H .. 9FH :  (* load_imm 0..15 *)
        Push (VAL (LONGCARD, opc MOD 16)) ;

    | 0A0H :  (* equal *)
        b := Pop () ; a := Pop () ;
        PushBool (a = b) ;
    | 0A1H :  (* not_equal *)
        b := Pop () ; a := Pop () ;
        PushBool (a # b) ;
    | 0A2H :  (* uless *)
        b := Pop () ; a := Pop () ;
        PushBool (Low32 (a) < Low32 (b)) ;
    | 0A3H :  (* ugreater *)
        b := Pop () ; a := Pop () ;
        PushBool (Low32 (a) > Low32 (b)) ;
    | 0A4H :  (* uless_eq *)
        b := Pop () ; a := Pop () ;
        PushBool (Low32 (a) <= Low32 (b)) ;
    | 0A5H :  (* ugreater_eq *)
        b := Pop () ; a := Pop () ;
        PushBool (Low32 (a) >= Low32 (b)) ;
    | 0A6H :  (* add (CARDINAL mod 2^32) *)
        b := Pop () ; a := Pop () ;
        Push (VAL (LONGCARD, Low32 (a) + Low32 (b))) ;
    | 0A7H :  (* sub *)
        b := Pop () ; a := Pop () ;
        Push (VAL (LONGCARD, Low32 (a) - Low32 (b))) ;
    | 0A8H :  (* umul *)
        b := Pop () ; a := Pop () ;
        Push (VAL (LONGCARD, Low32 (a) * Low32 (b))) ;
    | 0A9H :  (* udiv *)
        b := Pop () ; a := Pop () ;
        IF Low32 (b) = 0 THEN Fatal ("divide by zero") END ;
        Push (VAL (LONGCARD, Low32 (a) DIV Low32 (b))) ;
    | 0AAH :  (* umod *)
        b := Pop () ; a := Pop () ;
        IF Low32 (b) = 0 THEN Fatal ("divide by zero") END ;
        Push (VAL (LONGCARD, Low32 (a) MOD Low32 (b))) ;
    | 0ABH :  (* eq0 *)
        PushBool (Pop () = 0) ;
    | 0ACH :  (* inc *)
        Push (VAL (LONGCARD, Low32 (Pop ()) + 1)) ;
    | 0ADH :  (* dec *)
        Push (VAL (LONGCARD, Low32 (Pop ()) - 1)) ;
    | 0AEH :  (* add_imm u8 *)
        Push (VAL (LONGCARD, Low32 (Pop ()) + Fetch ())) ;
    | 0AFH :  (* sub_imm u8 *)
        Push (VAL (LONGCARD, Low32 (Pop ()) - Fetch ())) ;
    | 0B0H :  (* shl_imm u8 *)
        n := Fetch () ;
        v := Pop () ;
        IF n >= 32 THEN
          Push (0) ;
        ELSE
          Push (VAL (LONGCARD, Low32 (v) * VAL (CARDINAL, Shl64 (1, n)))) ;
        END ;
    | 0B1H :  (* shr_imm *)
        n := Fetch () ;
        v := Pop () ;
        IF n >= 32 THEN
          Push (0) ;
        ELSE
          Push (VAL (LONGCARD, Low32 (v) DIV VAL (CARDINAL, Shl64 (1, n)))) ;
        END ;
    | 0B2H :  (* iless *)
        b := Pop () ; a := Pop () ;
        PushBool (VAL (INTEGER, Low32 (a)) < VAL (INTEGER, Low32 (b))) ;
    | 0B3H :  (* igreater *)
        b := Pop () ; a := Pop () ;
        PushBool (VAL (INTEGER, Low32 (a)) > VAL (INTEGER, Low32 (b))) ;
    | 0B4H :  (* iless_eq *)
        b := Pop () ; a := Pop () ;
        PushBool (VAL (INTEGER, Low32 (a)) <= VAL (INTEGER, Low32 (b))) ;
    | 0B5H :  (* igreater_eq *)
        b := Pop () ; a := Pop () ;
        PushBool (VAL (INTEGER, Low32 (a)) >= VAL (INTEGER, Low32 (b))) ;
    | 0B6H :  (* not *)
        PushBool (NOT PopBool ()) ;
    | 0B7H :  (* complement (32-bit ~) *)
        Push (VAL (LONGCARD, 0FFFFFFFFH - Low32 (Pop ()))) ;
    | 0B8H :  (* imul (INTEGER mod 2^32) *)
        b := Pop () ; a := Pop () ;
        Push (VAL (LONGCARD, Low32 (a) * Low32 (b))) ;
    | 0B9H :  (* idiv *)
        b := Pop () ; a := Pop () ;
        IF Low32 (b) = 0 THEN Fatal ("divide by zero") END ;
        Push (VAL (LONGCARD, VAL (INTEGER, Low32 (a)) DIV VAL (INTEGER, Low32 (b)))) ;
    | 0BAH :  (* long_to_card *)
        Push (VAL (LONGCARD, Low32 (Pop ()))) ;
    | 0BBH :  (* long_to_int *)
        v := Pop () ;
        Push (VAL (LONGCARD, VAL (INTEGER, Low32 (v)))) ;
    | 0BCH :  (* abs *)
        v := Pop () ;
        IF VAL (INTEGER, Low32 (v)) < 0 THEN
          Push (VAL (LONGCARD, 0 - VAL (INTEGER, Low32 (v)))) ;
        ELSE
          Push (v) ;
        END ;
    | 0BDH :  (* int_to_long *)
        Push (VAL (LONGCARD, VAL (INTEGER, Low32 (Pop ())))) ;
    | 0BEH :  (* long_to_real *)
        PushReal (FLOAT (VAL (LONGINT, Pop ()))) ;
    | 0BFH :  (* real_to_long *)
        Push (VAL (LONGCARD, VAL (INTEGER, TRUNC (PopReal ())))) ;

    | 0C0H :  (* uadd_checked *)
        b := Pop () ; a := Pop () ;
        IF Low32 (a) + Low32 (b) < Low32 (a) THEN Fatal ("overflow") END ;
        Push (VAL (LONGCARD, Low32 (a) + Low32 (b))) ;
    | 0C1H :  (* usub_checked *)
        b := Pop () ; a := Pop () ;
        IF Low32 (a) < Low32 (b) THEN Fatal ("overflow") END ;
        Push (VAL (LONGCARD, Low32 (a) - Low32 (b))) ;
    | 0C2H :  (* umul_checked *)
        b := Pop () ; a := Pop () ;
        w := VAL (LONGCARD, Low32 (a)) * VAL (LONGCARD, Low32 (b)) ;
        IF w > 0FFFFFFFFH THEN Fatal ("overflow") END ;
        Push (VAL (LONGCARD, Low32 (a) * Low32 (b))) ;
    | 0C3H :  (* system host call *)
        v := Pop () ;
        Service (v, Pop ()) ;
    | 0C4H :  (* string_comp *)
        ssz := Pop () ; sz := Pop () ; src := Pop () ; dst := Pop () ;
        np := 0 ;
        last := 0 ;
        done := FALSE ;
        WHILE NOT done DO
          IF (np >= sz) OR (np >= ssz) THEN done := TRUE
          ELSIF ReadByte (src + np) = 0 THEN done := TRUE
          ELSIF ReadByte (src + np) > ReadByte (dst + np) THEN
            last := 1 ; done := TRUE
          ELSIF ReadByte (src + np) < ReadByte (dst + np) THEN
            last := 2 ; done := TRUE
          ELSE
            np := np + 1 ;
          END ;
        END ;
        IF last = 1 THEN
          Push (1) ; Push (0) ;
        ELSIF last = 2 THEN
          Push (0) ; Push (1) ;
        ELSE
          Push (0) ; Push (0) ;
        END ;
    | 0C5H :  (* long_compare : push (a>b) then (a<b) *)
        b := Pop () ; a := Pop () ;
        gl := VAL (LONGINT, a) ; bl := VAL (LONGINT, b) ;
        IF gl > bl THEN Push (1) ELSE Push (0) END ;
        IF gl < bl THEN Push (1) ELSE Push (0) END ;
    | 0C6H :  (* long_add *)
        b := Pop () ; a := Pop () ;
        Push (a + b) ;
    | 0C7H :  (* long_sub *)
        b := Pop () ; a := Pop () ;
        Push (a - b) ;
    | 0C8H :  (* long_mul *)
        b := Pop () ; a := Pop () ;
        Push (Mul64 (a, b)) ;
    | 0C9H :  (* long_div *)
        b := Pop () ; a := Pop () ;
        IF b = 0 THEN Fatal ("divide by zero") END ;
        Push (VAL (LONGCARD, VAL (LONGINT, a) DIV VAL (LONGINT, b))) ;
    | 0CAH :  (* long_mod *)
        b := Pop () ; a := Pop () ;
        IF b = 0 THEN Fatal ("divide by zero") END ;
        Push (VAL (LONGCARD, VAL (LONGINT, a) MOD VAL (LONGINT, b))) ;
    | 0CBH :  (* not_zero *)
        PushBool (Pop () # 0) ;
    | 0CCH :  (* long_abs *)
        v := Pop () ;
        IF VAL (LONGINT, v) < 0 THEN
          Push (0 - v) ;
        ELSE
          Push (v) ;
        END ;
    | 0CDH :  (* switch *)
        v := Pop () ;
        loww := FetchQuad () ;
        highw := FetchQuad () ;
        t := FetchQuad () ;  (* retOffset, must be 0 *)
        first := GetIP () ;
        eot := first + (highw - loww + 1) * 8 ;
        IF (v < loww) OR (v > highw) THEN
          SetIP (eot) ;
        ELSE
          cell := first + (v - loww) * 8 ;
          off := ReadSlot (cell) ;
          IF VAL (LONGINT, off) < 0 THEN
            Push (eot + t) ;
          END ;
          SetIP (cell + 8 + off) ;
        END ;
    | 0CEH :  (* jump_stack : computed jump *)
        SetIP (Pop ()) ;
    | 0CFH :  (* push_code_addr u64 *)
        off := FetchQuad () ;
        Push (GetIP () - 1 + off) ;
    | 0D0H :  (* iadd_checked *)
        b := Pop () ; a := Pop () ;
        tm := VAL (INTEGER, Low32 (a)) + VAL (INTEGER, Low32 (b)) ;
        IF ((VAL (INTEGER, Low32 (a)) > 0) AND (VAL (INTEGER, Low32 (b)) > 0)
            AND (tm < 0)) OR
           ((VAL (INTEGER, Low32 (a)) < 0) AND (VAL (INTEGER, Low32 (b)) < 0)
            AND (tm >= 0)) THEN
          Fatal ("overflow") ;
        END ;
        Push (VAL (LONGCARD, tm)) ;
    | 0D1H :  (* isub_checked *)
        b := Pop () ; a := Pop () ;
        tm := VAL (INTEGER, Low32 (a)) - VAL (INTEGER, Low32 (b)) ;
        IF ((VAL (INTEGER, Low32 (a)) > 0) AND (VAL (INTEGER, Low32 (b)) < 0)
            AND (tm < 0)) OR
           ((VAL (INTEGER, Low32 (a)) < 0) AND (VAL (INTEGER, Low32 (b)) > 0)
            AND (tm >= 0)) THEN
          Fatal ("overflow") ;
        END ;
        Push (VAL (LONGCARD, tm)) ;
    | 0D2H :  (* reserve *)
        sz := Pop () ;
        IF GetSP () < sz THEN Fatal ("stack overflow") END ;
        SetSP (GetSP () - sz) ;
        Push (GetSP ()) ;
    | 0D3H :  (* reserve_string *)
        st := Pop () ;
        sz := Pop () ;
        nw := VAL (CARDINAL, (sz + 7) DIV 8) ;
        dst := GetSP () - VAL (LONGCARD, nw) * 8 ;
        SetSP (dst) ;
        i := 0 ;
        WHILE i < VAL (LONGCARD, nw) DO
          WriteSlot (dst + i * 8, ReadSlot (st + i * 8)) ;
          i := i + 1 ;
        END ;
        Push (dst) ;
    | 0D4H :  (* enter u8 *)
        Enter (Fetch ()) ;
    | 0D5H :  (* real_compare *)
        r2 := PopReal () ; r1 := PopReal () ;
        IF r1 > r2 THEN Push (1) ELSE Push (0) END ;
        IF r1 < r2 THEN Push (1) ELSE Push (0) END ;
    | 0D6H :  (* real_add *)
        r2 := PopReal () ; r1 := PopReal () ;
        PushReal (r1 + r2) ;
    | 0D7H :  (* real_sub *)
        r2 := PopReal () ; r1 := PopReal () ;
        PushReal (r1 - r2) ;
    | 0D8H :  (* real_mul *)
        r2 := PopReal () ; r1 := PopReal () ;
        PushReal (r1 * r2) ;
    | 0D9H :  (* real_div *)
        r2 := PopReal () ; r1 := PopReal () ;
        PushReal (r1 / r2) ;
    | 0DAH :  (* urange_check *)
        sz := Pop () ; loww := Pop () ; v := Pop () ;
        IF (v < loww) OR (v >= loww + sz) THEN Fatal ("range error") END ;
    | 0DBH :  (* irange_check *)
        sz := Pop () ; loww := Pop () ; v := Pop () ;
        IF (VAL (INTEGER, Low32 (v)) < VAL (INTEGER, Low32 (loww))) OR
           (VAL (INTEGER, Low32 (v)) >=
            VAL (INTEGER, Low32 (loww)) + VAL (INTEGER, Low32 (sz))) THEN
          Fatal ("range error") ;
        END ;
    | 0DCH :  (* limit_check u8 *)
        n := Fetch () ;
        v := Pop () ; Push (v) ;
        IF v > VAL (LONGCARD, n) THEN Fatal ("range error") END ;
    | 0DDH :  (* check_positive *)
        v := Pop () ; Push (v) ;
        IF VAL (INTEGER, Low32 (v)) < 0 THEN Fatal ("range error") END ;
    | 0DEH :  (* and_jp u8 *)
        n := Fetch () ;
        IF NOT PopBool () THEN
          Push (0) ;
          SetIP (GetIP () + VAL (LONGCARD, n)) ;
        END ;
    | 0DFH :  (* or_jp u8 *)
        n := Fetch () ;
        IF PopBool () THEN
          Push (1) ;
          SetIP (GetIP () + VAL (LONGCARD, n)) ;
        END ;

    | 0E0H :  (* jp i64 *)
        rel := FetchQuad () ;
        SetIP (GetIP () + rel) ;
    | 0E1H :  (* jpfalse i64 *)
        rel := FetchQuad () ;
        IF NOT PopBool () THEN
          SetIP (GetIP () + rel) ;
        END ;
    | 0E2H :  (* jp_fwd i8 *)
        SetIP (GetIP () + VAL (LONGCARD, FetchSignedByte ())) ;
    | 0E3H :  (* jpfalse_fwd i8 *)
        n := FetchSignedByte () ;
        IF NOT PopBool () THEN
          SetIP (GetIP () + VAL (LONGCARD, n)) ;
        END ;
    | 0E4H :  (* jp_back u8 *)
        SetIP (GetIP () - VAL (LONGCARD, Fetch ())) ;
    | 0E5H :  (* jpfalse_back u8 *)
        n := Fetch () ;
        IF NOT PopBool () THEN
          SetIP (GetIP () - VAL (LONGCARD, n)) ;
        END ;
    | 0E6H :  (* bit_or *)
        b := Pop () ; a := Pop () ;
        Push (BitOp (a, b, 1)) ;
    | 0E7H :  (* bit_in *)
        b := Pop () ; a := Pop () ;
        IF b < 64 THEN
          PushBool (BitOp (a, Shl64 (1, VAL (CARDINAL, b)), 0) # 0) ;
        ELSE
          Push (0) ;
        END ;
    | 0E8H :  (* bit_and *)
        b := Pop () ; a := Pop () ;
        Push (BitOp (a, b, 0)) ;
    | 0E9H :  (* bit_xor (OR minus AND) *)
        b := Pop () ; a := Pop () ;
        Push (BitOp (a, b, 2)) ;
    | 0EAH :  (* power2 *)
        v := Pop () ;
        Push (Shl64 (1, VAL (CARDINAL, v) MOD 64)) ;
    | 0EBH :  (* extern_proc_call *)
        v := Pop () ;
        p := Pop () ;
        SetOFP (GetGP ()) ;
        SetGP (p) ;
        SetCurrentModule (FindModuleByBase (p)) ;
        Push (GetIP ()) ;
        SetIP (v) ;
    | 0ECH :  (* nested_call u8 *)
        n := Fetch () ;
        SetOFP (GetFP ()) ;
        Push (GetIP ()) ;
        SetIP (ProcedureAddress (GetCurrentModule (), n)) ;
    | 0EDH :  (* proc_call u8 *)
        n := Fetch () ;
        SetOFP (0) ;
        Push (GetIP ()) ;
        SetIP (ProcedureAddress (GetCurrentModule (), n)) ;
    | 0EEH :  (* call_with_frame u8 *)
        p := Pop () ;
        n := Fetch () ;
        SetOFP (p) ;
        Push (GetIP ()) ;
        SetIP (ProcedureAddress (GetCurrentModule (), n)) ;
    | 0EFH :  (* extern_call mod,proc *)
        m := Fetch () ;
        n := Fetch () ;
        SetOFP (GetGP ()) ;
        SetGP (GetModuleBase (m)) ;
        SetCurrentModule (m) ;
        Push (GetIP ()) ;
        SetIP (ProcedureAddress (m, n)) ;
    | 0F0H :  (* extern_call_nib nibble *)
        nw := Fetch () ;
        m := nw DIV 16 ;
        n := nw MOD 16 ;
        SetOFP (GetGP ()) ;
        SetGP (GetModuleBase (m)) ;
        SetCurrentModule (m) ;
        Push (GetIP ()) ;
        SetIP (ProcedureAddress (m, n)) ;
    | 0F1H .. 0FFH :  (* call 1..15 *)
        SetOFP (0) ;
        Push (GetIP ()) ;
        SetIP (ProcedureAddress (GetCurrentModule (), opc MOD 16)) ;
    ELSE
        Fatal ("internal: opcode not handled") ;
    END ;  (* CASE *)
  END ;  (* LOOP *)
END Run ;

END Interpreter.