MODULE mkdtest ;

(* Generates example.MC4, a single-module MC64 image that exercises far
   more of the interpreter than boot.MC4 :

     proc0 (TOINIT, main) :
       - a CARDINAL do-while loop  g := g*2+1  (10 iterations)  -> 2047
       - 32-bit arithmetic : add sub mul div mod
       - bit set ops / power2 (BitOp, Shl64)
       - 0x40 extended dispatch : drop, uc_add, uc_mul, uc_div, uc_mod,
         long_negate, build_field_mask
       - load_imm_word (0x8E), real arithmetic (real_add -> real_to_long)
       - dup / swap / copy_block
       - control flow : jp_fwd (0xE2), jpfalse_back (0xE5), jp_back (0xE4)
       - load/store global (0x2D/0x3D), global_dw (0x09), local_dw
         (0x08/0x18), proc_call (0xED) to proc1

     proc1 (print_num) :
       prints the CARDINAL in FP[3] as decimal text followed by CRLF via
       the SYSTEM write-string service.  Exercises Enter/Leave (0xD4/0x85),
       load_param (0x03), reserve (0xD2), udiv/umod (0xA9/0xAA),
       store_indexed_byte (0x1D) and a do-while digit loop. *)

FROM FileIO IMPORT WriteFile ;
FROM Console IMPORT Fatal ;
FROM SYSTEM IMPORT ADR ;

CONST
  HeaderSize = 64 ;
  DescName = 264 ;
  DescChecksum = 288 ;
  DescFlags = 292 ;
  DescVarCount = 293 ;
  DescDepCount = 294 ;
  DescProcs = 296 ;
  ProcTable = 304 ;
  CodeOff = 312 ;
  BufSize = 4096 ;

VAR
  buf : ARRAY [0 .. BufSize - 1] OF CHAR ;
  pcimg : CARDINAL ;        (* image-relative cursor into the code *)
  i, sum : CARDINAL ;
  lp : CARDINAL ;           (* loop label *)
  p1, pt : CARDINAL ;       (* image offsets of proc1 and the proc table *)

TYPE
  RealView = RECORD CASE : BOOLEAN OF
               | TRUE : r : REAL ;
               | FALSE : w : LONGCARD ;
             END ;
           END ;

VAR
  rv : RealView ;

PROCEDURE Op (o : CARDINAL) ;
BEGIN
  buf [HeaderSize + pcimg] := CHR (o MOD 256) ;
  INC (pcimg) ;
END Op ;

PROCEDURE OpB (o, b : CARDINAL) ;
BEGIN
  Op (o) ;
  buf [HeaderSize + pcimg] := CHR (b MOD 256) ;
  INC (pcimg) ;
END OpB ;

PROCEDURE Put32 (off, v : CARDINAL) ;
BEGIN
  buf [off] := CHR (v MOD 256) ;
  buf [off + 1] := CHR ((v DIV 256) MOD 256) ;
  buf [off + 2] := CHR ((v DIV 65536) MOD 256) ;
  buf [off + 3] := CHR (v DIV 16777216) ;
END Put32 ;

PROCEDURE Put64 (off : CARDINAL ; v : LONGCARD) ;
VAR j : CARDINAL ;
BEGIN
  FOR j := 0 TO 7 DO
    buf [off + j] := CHR (VAL (CARDINAL, v MOD 256)) ;
    v := v DIV 256 ;
  END ;
END Put64 ;

PROCEDURE ImmB (b : CARDINAL) ;
BEGIN
  OpB (8DH, b) ;             (* load_imm_byte *)
END ImmB ;

PROCEDURE ImmU64 (v : LONGCARD) ;
BEGIN
  Op (8EH) ;                 (* load_imm_word, 8-byte immediate *)
  Put64 (HeaderSize + pcimg, v) ;
  INC (pcimg, 8) ;
END ImmU64 ;

PROCEDURE Cg (n : CARDINAL) ;
BEGIN
  OpB (2DH, n) ;             (* load_global *)
END Cg ;

PROCEDURE Sg (n : CARDINAL) ;
BEGIN
  OpB (3DH, n) ;             (* store_global *)
END Sg ;

PROCEDURE Mark (VAR m : CARDINAL) ;
BEGIN
  m := pcimg ;
END Mark ;

PROCEDURE JBack (o : CARDINAL ; m : CARDINAL) ;
BEGIN
  Op (o) ;
  buf [HeaderSize + pcimg] := CHR (pcimg + 1 - m) ;
  INC (pcimg) ;
END JBack ;

PROCEDURE EStr (s : ARRAY OF CHAR ; nl : BOOLEAN) ;
VAR len, i2 : CARDINAL ;
BEGIN
  Op (8CH) ;                 (* call_rel : pc-relative string pointer *)
  IF nl THEN
    len := LENGTH (s) + 3 ;
  ELSE
    len := LENGTH (s) + 1 ;
  END ;
  buf [HeaderSize + pcimg] := CHR (len) ;
  INC (pcimg) ;
  IF LENGTH (s) > 0 THEN
    FOR i2 := 0 TO LENGTH (s) - 1 DO
      buf [HeaderSize + pcimg + i2] := s [i2] ;
    END ;
  END ;
  INC (pcimg, LENGTH (s)) ;
  IF nl THEN
    buf [HeaderSize + pcimg] := CHR (13) ;   (* CR *)
    buf [HeaderSize + pcimg + 1] := CHR (10) ;   (* LF *)
    INC (pcimg, 2) ;
  END ;
  buf [HeaderSize + pcimg] := 0C ;           (* NUL *)
  INC (pcimg) ;
END EStr ;

PROCEDURE PrintStr ;
BEGIN
  ImmB (1) ;                 (* system id = write NUL-terminated string *)
  Op (0C3H) ;                (* system *)
END PrintStr ;

PROCEDURE Label (s : ARRAY OF CHAR) ;
BEGIN
  EStr (s, FALSE) ;
  PrintStr ;
END Label ;

PROCEDURE Nl ;
BEGIN
  EStr ("", TRUE) ;
  PrintStr ;
END Nl ;

PROCEDURE CallPrint ;
BEGIN
  OpB (0EDH, 1) ;            (* proc_call 1 *)
END CallPrint ;

PROCEDURE RealBits (v : REAL) ;
BEGIN
  rv.r := v ;
  Op (8EH) ;
  Put64 (HeaderSize + pcimg, rv.w) ;
  INC (pcimg, 8) ;
END RealBits ;

BEGIN
  FOR i := 0 TO BufSize - 1 DO
    buf [i] := 0C ;
  END ;

  (* file header : magic *)
  buf [0] := 'M' ;
  buf [1] := 'C' ;
  buf [2] := '6' ;
  buf [3] := '4' ;

  (* descriptor *)
  buf [HeaderSize + DescName] := 'e' ;
  buf [HeaderSize + DescName + 1] := 'x' ;
  buf [HeaderSize + DescName + 2] := 'a' ;
  buf [HeaderSize + DescName + 3] := 'm' ;
  buf [HeaderSize + DescName + 4] := 'p' ;
  buf [HeaderSize + DescName + 5] := 'l' ;
  buf [HeaderSize + DescName + 6] := 'e' ;
  buf [HeaderSize + DescFlags] := CHR (4) ;      (* TOINIT *)
  buf [HeaderSize + DescVarCount] := CHR (0) ;
  buf [HeaderSize + DescDepCount] := CHR (0) ;
  (* DescProcs is filled in once the table position is known *)

  pcimg := CodeOff ;

  (* ================= proc0 : main *)

  OpB (0D4H, 250) ;          (* enter : 5 local slots *)

  Label ("mc64 test vm :: opcode exercise") ;  Nl ;

  (* --- CARDINAL do-while loop : g := g*2+1, 10 iterations -> 1023 *)
  ImmB (1) ; Sg (0) ;        (* g := 1 *)
  ImmB (10) ; Sg (2) ;       (* i := 10 *)
  Mark (lp) ;
  Cg (0) ; ImmB (2) ; Op (0A8H) ; OpB (0AEH, 1) ; Sg (0) ;   (* g := g*2+1 *)
  Cg (2) ; Op (0ADH) ; Sg (2) ;                              (* i := i-1 *)
  Cg (2) ; Op (0ABH) ;                                       (* (i = 0)? *)
  JBack (0E5H, lp) ;         (* jpfalse_back while i # 0 *)

  Label ("g after 10*2+1 = ") ;  Cg (0) ; CallPrint ;

  Label ("add 10+6 = ") ;      ImmB (10) ; ImmB (6) ; Op (0A6H) ; CallPrint ;
  Label ("sub 20-7 = ") ;      ImmB (20) ; ImmB (7) ; Op (0A7H) ; CallPrint ;
  Label ("mul 6*7 = ") ;       ImmB (6) ; ImmB (7) ; Op (0A8H) ; CallPrint ;
  Label ("div 100/8 = ") ;     ImmB (100) ; ImmB (8) ; Op (0A9H) ; CallPrint ;
  Label ("mod 100%8 = ") ;     ImmB (100) ; ImmB (8) ; Op (0AAH) ; CallPrint ;

  Label ("bitand FF&0F = ") ;  ImmB (255) ; ImmB (15) ; Op (0E8H) ; CallPrint ;
  Label ("bitor F0|0F = ") ;   ImmB (240) ; ImmB (15) ; Op (0E6H) ; CallPrint ;
  Label ("bitxor FF^0F = ") ;  ImmB (255) ; ImmB (15) ; Op (0E9H) ; CallPrint ;
  Label ("power2 2^6 = ") ;    ImmB (6) ; Op (0EAH) ; CallPrint ;

  Label ("uc_add (2^32-1)+2 = ") ;
    ImmU64 (0FFFFFFFFH) ; ImmB (2) ; Op (40H) ; Op (18H) ;
    Op (0BAH) ; CallPrint ;

  Label ("uc_mul 1234567890*2 = ") ;
    ImmU64 (1234567890) ; ImmB (2) ; Op (40H) ; Op (1AH) ;
    Op (0BAH) ; CallPrint ;

  Label ("uc_div 2^36/2^16 = ") ;
    ImmU64 (1000000000H) ;
    ImmU64 (65536) ;
    Op (40H) ; Op (1BH) ; Op (0BAH) ; CallPrint ;

  Label ("uc_mod (2^32+6) rem 16 = ") ;
    ImmU64 (100000006H) ; ImmB (16) ;
    Op (40H) ; Op (1CH) ; Op (0BAH) ; CallPrint ;

  Label ("long_negate F0F0F0F0 low = ") ;
    ImmU64 (4042322160) ; Op (40H) ; Op (03H) ;
    Op (0BAH) ; CallPrint ;

  Label ("field_mask (1<<8)-(1<<2) = ") ;
    ImmB (2) ; ImmB (8) ; Op (40H) ; Op (04H) ; CallPrint ;

  Label ("real_add 3.5+2.25 = ") ;
    RealBits (3.5) ; RealBits (2.25) ; Op (0D6H) ; Op (0BFH) ; CallPrint ;

  Label ("dup+add check = ") ;
    ImmB (2) ; Op (20H) ; Op (0A6H) ; ImmB (1) ; Op (0A6H) ; CallPrint ;

  Label ("swap check = ") ;
    ImmB (1) ; ImmB (2) ; Op (21H) ; Op (0A6H) ; CallPrint ;

  Label ("load_global_dw g = ") ;
    Op (09H) ; Op (00H) ; CallPrint ;

  Label ("local_dw FP[-2] = ") ;
    ImmB (99) ; OpB (18H, 0FEH) ;        (* store_local_dw -2 *)
    OpB (08H, 0FEH) ; CallPrint ;        (* load_local_dw -2 *)

  Label ("drop then 12 = ") ;
    ImmB (11) ; Op (40H) ; Op (00H) ;    (* drop *)
    ImmB (12) ; CallPrint ;

  Label ("jp_fwd skip -> 7 = ") ;
    Op (0E2H) ; Op (03H) ;               (* forward jump over 3 bytes *)
    ImmB (5) ; Op (0A6H) ;               (* skipped at run time *)
    ImmB (7) ; CallPrint ;

  Label ("copy_block -> ") ;
  ImmB (4) ; Op (0D2H) ; Op (20H) ;        (* dst := reserve 4 ; keep a copy *)
  EStr ("abc", FALSE) ;                    (* src string inline (call_rel) *)
  ImmB (4) ; Op (30H) ;                    (* copy_block : dst, src, size *)
  PrintStr ;                               (* write the copied "abc" *)
  Nl ;

  Op (50H) ;                             (* end_program *)

  p1 := pcimg ;

  (* ================= proc1 : print_num *)

  OpB (0D4H, 250) ;          (* enter : 5 local slots *)

  ImmB (16) ; Op (0D2H) ; Sg (1) ;       (* GP[1] := output buffer *)
  Op (90H) ; Op (90H) ; Sg (2) ; Sg (3) ;  (* GP[2] count := 0, GP[3] index := 0 *)

  Op (03H) ;                             (* load_param 1 : the value *)

  Mark (lp) ;
  Cg (2) ; Op (0ACH) ; Sg (2) ;          (* count := count + 1 *)
  Op (20H) ; ImmB (10) ; Op (0AAH) ;     (* dup ; 10 ; umod  -> remainder *)
  Op (21H) ; ImmB (10) ; Op (0A9H) ;     (* swap ; 10 ; udiv  -> quotient *)
  Op (20H) ; Op (0ABH) ;                 (* dup ; eq0 (quotient = 0) *)
  JBack (0E5H, lp) ;                     (* jpfalse_back while quotient # 0 *)

  Op (40H) ; Op (00H) ;                  (* drop the trailing quotient 0 *)

  Mark (lp) ;
  ImmB (48) ; Op (0A6H) ; Sg (4) ;   (* GP[4] := char (digit + ORD('0')) *)
  Cg (1) ; Cg (3) ; Op (0A6H) ;      (* addr := buf + index *)
  Op (90H) ; Cg (4) ; Op (1DH) ;     (* buf [index] := char *)
  Cg (3) ; Op (0ACH) ; Sg (3) ;      (* index := index + 1 *)
  Cg (2) ; Op (0ADH) ; Sg (2) ;      (* count := count - 1 *)
  Cg (2) ; Op (0ABH) ;               (* (count = 0)? *)
  JBack (0E5H, lp) ;                 (* jpfalse_back while count # 0 *)

  Cg (1) ; Cg (3) ; Op (0A6H) ;      (* addr := buf + index *)
  Op (90H) ; Op (90H) ; Op (1DH) ;   (* buf [index] := 0 (NUL) *)

  Cg (1) ; PrintStr ;                    (* write the number *)
  Nl ;                                   (* CRLF *)

  OpB (85H, 0) ;                         (* fct_leave 0 *)

  (* procedure table, placed after the code so it never overlaps it *)
  pt := pcimg ;
  Put64 (HeaderSize + DescProcs, VAL (LONGCARD, pt)) ;
  Put64 (HeaderSize + pt, VAL (LONGCARD, 312) - VAL (LONGCARD, pt)) ;
  Put64 (HeaderSize + pt + 8,
         VAL (LONGCARD, p1) - VAL (LONGCARD, pt + 8)) ;
  INC (pcimg, 16) ;

  (* checksum over the image, excluding the checksum field *)
  sum := 0 ;
  FOR i := HeaderSize TO HeaderSize + pcimg - 1 DO
    IF NOT ((i >= 352) AND (i <= 355)) THEN
      sum := sum + ORD (buf [i]) ;
    END ;
  END ;
  Put32 (HeaderSize + DescChecksum, sum) ;

  IF NOT WriteFile ("example.MC4", buf, HeaderSize + pcimg) THEN
    Fatal ("mkdtest: cannot write example.MC4") ;
  END ;
END mkdtest.