m-code-64/Extended.mod

IMPLEMENTATION MODULE Extended ;

FROM Instruction IMPORT Fetch ;
FROM Stack IMPORT Pop, Push, PopReal, PushReal ;
FROM Memory IMPORT CopyBytes, FillBytes, WriteSlot, ReadSlot,
  TopOfMemory ;
FROM Local IMPORT GetSP, SetSP ;
FROM Console IMPORT Fatal ;

VAR
  hp : LONGCARD ;

PROCEDURE HeapPtr () : LONGCARD ;
BEGIN
  IF hp = 0 THEN
    hp := TopOfMemory () ;
  END ;
  RETURN hp ;
END HeapPtr ;

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 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 AllocateHeap (size: LONGCARD) : LONGCARD ;
VAR sz: LONGCARD ;
BEGIN
  sz := size ;
  IF (sz MOD 8) # 0 THEN
    sz := sz + 8 - (sz MOD 8) ;
  END ;
  hp := HeapPtr () - sz ;
  RETURN hp ;
END AllocateHeap ;

PROCEDURE Execute ;
VAR sfun, hbit, lbit: CARDINAL ;
    dst, src, size, a, b, v, mark: LONGCARD ;
    nw, i, sp: LONGCARD ;
BEGIN
  sfun := Fetch () ;
  CASE sfun OF
  | 0 :  (* drop *)
      v := Pop () ;
  | 1, 2 :  (* enter/leave monitor : no-op *)
  | 3 :  (* long_negate *)
      v := Pop () ;
      Push (0 - v) ;
  | 4 :  (* build_field_mask : (1<<hi) - (1<<lo) *)
      hbit := VAL (CARDINAL, Pop ()) ;
      lbit := VAL (CARDINAL, Pop ()) ;
      Push (Shl64 (1, hbit MOD 64) - Shl64 (1, lbit MOD 64)) ;
  | 5 :  (* ALLOCATE *)
      size := Pop () ;
      dst := Pop () ;
      WriteSlot (dst, AllocateHeap (size)) ;
  | 6 :  (* DEALLOCATE (no-op free) *)
      size := Pop () ;
      dst := Pop () ;
      WriteSlot (dst, 0) ;
  | 7 :  (* MARK *)
      dst := Pop () ;
      WriteSlot (dst, HeapPtr ()) ;
  | 8 :  (* RELEASE *)
      dst := Pop () ;
      mark := ReadSlot (dst) ;
      hp := mark ;
      WriteSlot (dst, 0) ;
  | 9 :  (* FREEMEM *)
      Push (TopOfMemory () - HeapPtr ()) ;
  | 0AH, 0BH, 0CH :  (* TRANSFER/IOTRANSFER/NEWPROCESS *)
      Fatal ("extended: processes unimplemented") ;
  | 0DH :  (* BIOS (no-op) *)
      sfun := VAL (CARDINAL, Pop ()) ;
      v := Pop () ;
  | 0EH :  (* MOVE *)
      size := Pop () ;
      dst := Pop () ;
      src := Pop () ;
      CopyBytes (src, dst, size) ;
  | 0FH :  (* FILL *)
      v := Pop () ;
      size := Pop () ;
      src := Pop () ;
      FillBytes (src, size, VAL (CARDINAL, v)) ;
  | 10H :  (* INP (no-op) *)
      Push (0) ;
  | 11H :  (* OUT (no-op) *)
      sfun := VAL (CARDINAL, Pop ()) ;
      v := Pop () ;
  | 12H :  (* reserve_string *)
      src := Pop () ;
      size := Pop () ;
      nw := (size + 7) DIV 8 ;
      dst := GetSP () - nw * 8 ;
      SetSP (dst) ;
      i := 0 ;
      WHILE i < nw DO
        WriteSlot (dst + i * 8, ReadSlot (src + i * 8)) ;
        i := i + 1 ;
      END ;
      Push (dst) ;
  | 13H :  (* assert : pop 0 -> raise RangeError *)
      v := Pop () ;
      IF v = 0 THEN
        Fatal ("assertion failed") ;
      END ;
  | 14H :  (* uc_less *)
      b := Pop () ; a := Pop () ;
      IF a < b THEN Push (1) ELSE Push (0) END ;
  | 15H :  (* uc_less_eq *)
      b := Pop () ; a := Pop () ;
      IF a <= b THEN Push (1) ELSE Push (0) END ;
  | 16H :  (* uc_greater *)
      b := Pop () ; a := Pop () ;
      IF a > b THEN Push (1) ELSE Push (0) END ;
  | 17H :  (* uc_greater_eq *)
      b := Pop () ; a := Pop () ;
      IF a >= b THEN Push (1) ELSE Push (0) END ;
  | 18H :  (* uc_add *)
      b := Pop () ; a := Pop () ;
      Push (a + b) ;
  | 19H :  (* uc_sub *)
      b := Pop () ; a := Pop () ;
      Push (a - b) ;
  | 1AH :  (* uc_mul *)
      b := Pop () ; a := Pop () ;
      Push (Mul64 (a, b)) ;
  | 1BH :  (* uc_div *)
      b := Pop () ; a := Pop () ;
      IF b = 0 THEN Fatal ("divide by zero") END ;
      Push (a DIV b) ;
  | 1CH :  (* uc_mod *)
      b := Pop () ; a := Pop () ;
      IF b = 0 THEN Fatal ("divide by zero") END ;
      Push (a MOD b) ;
  | 1DH :  (* uc_to_real *)
      v := Pop () ;
      PushReal (FLOAT (VAL (LONGINT, v))) ;
  | 1EH :  (* real_to_uc *)
      Push (VAL (LONGCARD, VAL (INTEGER, TRUNC (PopReal ())))) ;
  ELSE
      Fatal ("extended: illegal sub-opcode") ;
  END ;  (* CASE *)
END Execute ;

END Extended.