TP3/shell/tests/ComTest.mod

MODULE ComTest ;

(* Builds the linked .COM for fixtures and checks it, so the linker is tested
   by running it rather than by "it compiled".

   Reads fixture paths from stdin like CompileTest, and for each one prints

       <path>  OK  com=<bytes>  image=<bytes>  data=<bytes>

   plus, under @hex, the first bytes and the bytes around the code/data
   boundary - the two places where a linker bug would show up.

   What is actually being asserted, and why these bytes:

     * the file must be LinkSize bytes, i.e. padded past the code to cover
       the data area.  A .COM shorter than the data area leaves the globals
       outside the file, so the first read of a global reads whatever the
       loader happened to leave there.

     * the file's byte 0 must be the runtime's first byte (8B C0 = MOV AX,AX,
       the head of initmem).  If it is not, the runtime was not prepended and
       every CALL target is wrong.

     * the bytes from ImageBytes to the end must be ZERO.  That gap is what
       the program's globals live in, so an uninitialised filler byte would
       be a global that starts as garbage.

   The @hex dump is the last line of defence: it is what caught the header
   words being written with a nibble shift instead of a byte shift. *)

FROM Posix IMPORT read, write, open, close ;
FROM TextBuf IMPORT TextLimit, Clear, Length, CharAt, InsertCh ;
FROM Compiler IMPORT Compile, CodeBytes, DataBytes, ImageBytes, ImageByteAt, DataBase, SetSource ;
FROM Linker IMPORT LinkSize, WriteCom ;
FROM SYSTEM IMPORT ADR, BYTE ;

CONST
   STDIN = 0 ;
   STDOUT = 1 ;
   O_RDONLY = 0 ;
   O_RDONLY_RB = 0 ;

TYPE
   PathBuf = ARRAY [0..511] OF CHAR ;

VAR
   lineBuf  : ARRAY [0..255] OF CHAR ;
   pathCopy : PathBuf ;
   outPath  : PathBuf ;
   hexMode  : BOOLEAN ;
   hexOn    : BOOLEAN ;

PROCEDURE PutCh (ch : CHAR) ;
VAR n : LONGINT ;
BEGIN
   n := write (STDOUT, ADR (ch), 1)
END PutCh ;

PROCEDURE PutStr (s : ARRAY OF CHAR) ;
VAR i : CARDINAL ; n : LONGINT ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (s)) AND (s [i] # 0C) DO
      n := write (STDOUT, ADR (s [i]), 1) ;
      INC (i)
   END
END PutStr ;

PROCEDURE PutCard (n : CARDINAL) ;
VAR dig : ARRAY [0..9] OF CHAR ; i : CARDINAL ;
BEGIN
   IF n = 0 THEN
      PutCh ("0")
   ELSE
      i := 0 ;
      WHILE n > 0 DO
         dig [i] := CHR (ORD ("0") + (n MOD 10)) ;
         n := n DIV 10 ;
         INC (i)
      END ;
      WHILE i > 0 DO
         DEC (i) ;
         PutCh (dig [i])
      END
   END
END PutCard ;

PROCEDURE NL ;
BEGIN
   PutCh (CHR (13)) ; PutCh (CHR (10))
END NL ;

PROCEDURE Hex (b : BYTE ; VAR out : ARRAY OF CHAR) ;
VAR d : CARDINAL ;
BEGIN
   d := VAL (CARDINAL, b) DIV 16 ;
   IF d < 10 THEN
      out [0] := CHR (ORD ("0") + d)
   ELSE
      out [0] := CHR (ORD ("A") + d - 10)
   END ;
   d := VAL (CARDINAL, b) MOD 16 ;
   IF d < 10 THEN
      out [1] := CHR (ORD ("0") + d)
   ELSE
      out [1] := CHR (ORD ("A") + d - 10)
   END
END Hex ;

PROCEDURE PutHexNib (d : CARDINAL) ;
VAR c : CHAR ;
BEGIN
   IF d < 10 THEN
      c := CHR (ORD ("0") + d)
   ELSE
      c := CHR (ORD ("A") + d - 10)
   END ;
   PutCh (c)
END PutHexNib ;

PROCEDURE PutCardHex4 (n : CARDINAL) ;
VAR d : CARDINAL ;
BEGIN
   d := 4096 ;
   WHILE d > 0 DO
      PutHexNib ((n DIV d) MOD 16) ;
      d := d DIV 16
   END ;
   PutStr (":  ")
END PutCardHex4 ;

PROCEDURE StrCopy (VAR dst : ARRAY OF CHAR ; src : ARRAY OF CHAR) ;
VAR i : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (dst)) AND (i <= HIGH (src)) AND (src [i] # 0C) DO
      dst [i] := src [i] ;
      INC (i)
   END ;
   IF i <= HIGH (dst) THEN
      dst [i] := 0C
   END
END StrCopy ;

PROCEDURE AppStr (VAR dst : ARRAY OF CHAR ; s : ARRAY OF CHAR ) ;
VAR i, j : CARDINAL ;
BEGIN
   i := 0 ;
   WHILE (i <= HIGH (dst)) AND (dst [i] # 0C) DO
      INC (i)
   END ;
   j := 0 ;
   WHILE (j <= HIGH (s)) AND (s [j] # 0C) AND (i <= HIGH (dst)) DO
      dst [i] := s [j] ;
      INC (i) ; INC (j)
   END ;
   IF i <= HIGH (dst) THEN
      dst [i] := 0C
   END
END AppStr ;

PROCEDURE ReadLineStr (VAR s : ARRAY OF CHAR) : BOOLEAN ;
VAR ch : CHAR ; n : LONGINT ; i : CARDINAL ;
BEGIN
   i := 0 ; s [0] := 0C ;
   LOOP
      n := read (STDIN, ADR (ch), 1) ;
      IF n # 1 THEN
         IF i = 0 THEN RETURN FALSE END ;
         s [i] := 0C ; RETURN TRUE
      END ;
      IF (ch = CHR (10)) OR (ch = CHR (13)) THEN
         IF i = 0 THEN RETURN FALSE END ;
         s [i] := 0C ; RETURN TRUE
      END ;
      IF i < HIGH (s) THEN
         s [i] := ch ; INC (i)
      END
   END
END ReadLineStr ;

PROCEDURE LoadFile (p : ARRAY OF CHAR) : BOOLEAN ;
(* same CR/LF normalisation as the shell's LoadWorkFile *)
VAR fd : INTEGER ; k : LONGINT ; b : BYTE ; prevCR : BOOLEAN ;
    z : ARRAY [0..511] OF CHAR ;
BEGIN
   StrCopy (z, p) ;
   fd := open (ADR (z), O_RDONLY, 0) ;
   IF fd < 0 THEN
      RETURN FALSE
   END ;
   SetSource (z) ;                     (* {$I} resolves beside this file *)
   Clear ;
   prevCR := FALSE ;
   LOOP
      IF Length () >= TextLimit THEN EXIT END ;
      k := read (fd, ADR (b), 1) ;
      IF k # 1 THEN EXIT END ;
      IF b = 26 THEN
         EXIT
      ELSIF b = 10 THEN
         IF NOT prevCR THEN InsertCh (Length (), CHR (13)) END ;
         prevCR := FALSE
      ELSIF b = 13 THEN
         InsertCh (Length (), CHR (13)) ;
         prevCR := TRUE
      ELSE
         InsertCh (Length (), CHR (ORD (b))) ;
         prevCR := FALSE
      END
   END ;
   k := close (fd) ;
   RETURN TRUE
END LoadFile ;

(* ---- reading the .COM back ---------------------------------------- *)

VAR
   fbuf  : ARRAY [0..65535] OF BYTE ;
   fsize : CARDINAL ;

PROCEDURE ReadCom (p : ARRAY OF CHAR) : BOOLEAN ;
VAR fd : INTEGER ; k : LONGINT ; z : ARRAY [0..511] OF CHAR ;
BEGIN
   StrCopy (z, p) ;
   fd := open (ADR (z), O_RDONLY, 0) ;
   IF fd < 0 THEN
      RETURN FALSE
   END ;
   fsize := 0 ;
   LOOP
      IF fsize > 65535 THEN EXIT END ;
      k := read (fd, ADR (fbuf [fsize]), 65535 - fsize) ;
      IF k <= 0 THEN EXIT END ;
      fsize := fsize + VAL (CARDINAL, k)
   END ;
   k := close (fd) ;
   RETURN TRUE
END ReadCom ;

PROCEDURE DumpAt (at, cnt : CARDINAL) ;
VAR i, n : CARDINAL ; hx : ARRAY [0..1] OF CHAR ;
BEGIN
   PutStr ("        " ) ;
   PutCardHex4 (at) ;
   n := 0 ;
   WHILE (n < cnt) AND (at + n < fsize) DO
      Hex (fbuf [at + n], hx) ;
      PutCh (hx [0]) ; PutCh (hx [1]) ; PutCh (" ") ;
      INC (n)
   END ;
   NL
END DumpAt ;

(* Count non-zero bytes in [a,b) - the gap between the code and the data must
   be entirely zero, or a program's globals start as garbage. *)
PROCEDURE NonZero (a, b : CARDINAL) : CARDINAL ;
VAR i, k : CARDINAL ;
BEGIN
   k := 0 ; i := a ;
   WHILE (i < b) AND (i < fsize) DO
      IF fbuf [i] # 0 THEN
         k := k + 1
      END ;
      INC (i)
   END ;
   RETURN k
END NonZero ;

PROCEDURE BaseName (src : PathBuf ; VAR dst : PathBuf) ;
(* the fixture's own name, so the .COM lands beside us as NAME.COM rather
   than trying to graft a directory onto the source path.

   FIXED array formals, not open ones: with `VAR dst : ARRAY OF CHAR` the
   write did not reach the caller's buffer at all, so the .COM was written to
   a file named after whatever garbage was in the destination - literally
   "END", taken from adjacent string data.  An open-array VAR formal is not
   worth the subtlety in a test harness. *)
VAR i, j, last : CARDINAL ;
BEGIN
   i := 0 ; j := 0 ; last := 0 ;
   WHILE (i <= HIGH (src)) AND (src [i] # 0C) DO
      IF src [i] = "/" THEN
         last := i + 1
      END ;
      INC (i)
   END ;
   i := last ;
   WHILE (i <= HIGH (src)) AND (src [i] # 0C) AND (j <= HIGH (dst)) DO
      dst [j] := src [i] ;
      INC (i) ; INC (j)
   END ;
   (* drop the .pas and add .COM *)
   IF j > 4 THEN
      IF (dst [j - 4] = ".") AND (dst [j - 3] = "p") AND (dst [j - 2] = "a")
         AND (dst [j - 1] = "s") THEN
         j := j - 4
      END
   END ;
   IF j + 4 <= HIGH (dst) THEN
      dst [j] := "." ; dst [j + 1] := "C" ; dst [j + 2] := "O" ;
      dst [j + 3] := "M" ; dst [j + 4] := 0C
   END
END BaseName ;

PROCEDURE IsHexCmd () : BOOLEAN ;
VAR i : CARDINAL ;
BEGIN
   IF lineBuf [0] # "@" THEN RETURN FALSE END ;
   i := 0 ;
   WHILE (i <= HIGH (lineBuf)) AND (lineBuf [i] # 0C) DO INC (i) END ;
   IF i # 4 THEN RETURN FALSE END ;
   RETURN (lineBuf [1] = "h") AND (lineBuf [2] = "e") AND (lineBuf [3] = "x")
END IsHexCmd ;

VAR
   errNo, errPos : CARDINAL ;
   ok : BOOLEAN ;
   zout : PathBuf ;
   nz : CARDINAL ;

BEGIN
   PutStr ("FIXTURE  RESULT") ;
   NL ;
   WHILE ReadLineStr (lineBuf) DO
      IF IsHexCmd () THEN
         hexOn := TRUE
      ELSE
         StrCopy (pathCopy, lineBuf) ;
         IF LoadFile (pathCopy) THEN
            ok := Compile (errNo, errPos) ;
            IF ok THEN
               BaseName (pathCopy, zout) ;
               IF WriteCom (zout) THEN
                  IF ReadCom (zout) THEN
                     nz := NonZero (ImageBytes (), fsize) ;
                     PutStr (lineBuf) ;
                     PutStr ("  OK  com=") ;
                     PutCard (fsize) ;
                     PutStr (" image=") ;
                     PutCard (ImageBytes ()) ;
                     PutStr (" data=") ;
                     PutCard (DataBytes ()) ;
                     PutStr (" nonzeroInGap=") ;
                     PutCard (nz) ;
                     NL ;
                     IF hexOn THEN
                        DumpAt (0, 16) ;              (* runtime head *)
                        DumpAt (ImageBytes () - 16, 16) ;  (* code tail *)
                        DumpAt (ImageBytes (), 16)     (* the gap *)
                     END
                  ELSE
                     PutStr (lineBuf) ; PutStr ("  CANNOT READ BACK") ; NL
                  END
               ELSE
                  PutStr (lineBuf) ; PutStr ("  WRITE_COM_FAILED") ; NL
               END
            ELSE
               PutStr (lineBuf) ; PutStr ("  ERROR ") ;
               PutCard (errNo) ; PutStr (" at pos ") ; PutCard (errPos) ; NL
            END
         ELSE
            PutStr (lineBuf) ; PutStr ("  CANNOT OPEN") ; NL
         END
      END
   END
END ComTest.