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 = ImageBytes bytes, i.e. exactly the
       runtime and the program's code.  The globals live outside the file at
       Compiler.DataBase (8000h image, 8100h memory) and initmem zeroes them
       at startup, as the original's separate DS segment is zeroed.  A file
       padded to the data base would be a different layout, not this one.

     * the file's byte 0 must be the E9 entry jump (Compiler.Inittur); the
       runtime starts three bytes later.  If it is not, execution starts in
       the wrong place and every absolute address is still 0100h low.

     * there must be no byte past ImageBytes: the file is code-only, so a
       longer file means the linker is padding to the old data base again.

   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, 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 .COM is code-only now, so this is
   called with a = ImageBytes and b = fsize: it must be zero because there is
   no byte past the image.  The independent checker pins the file length; this
   line keeps the ComTest report honest about what was read back. *)
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)     (* past the file *)
                     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.