TP3/shell/tests/CompileTest.mod

MODULE CompileTest ;

(* Direct test harness for the TP3 compiler.

   Reads fixture paths from stdin, one per line, loads each into TextBuf
   exactly the way the shell's LoadWorkFile does, then calls Compiler.Compile
   and prints a one-line verdict plus a source excerpt with a caret under the
   error position.

   This is the fast loop for compiler work: no pty, no editor, no screen
   redraws - just Compile's own errNo / errPos, which is what actually
   matters.  (The pty harness in matrix.py covers the shell/editor UI.)

   Usage:  printf 'a.pas\nb.pas\n' | ./compiletest          *)

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

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

VAR
   lineBuf : ARRAY [0..255] OF CHAR ;
   pathCopy : ARRAY [0..511] OF CHAR ;
   txt     : ARRAY [0..79] OF CHAR ;
   mark    : ARRAY [0..79] OF CHAR ;

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 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 ReadLineStr (VAR s : ARRAY OF CHAR) : BOOLEAN ;
(* one line from stdin; FALSE at EOF/blank line *)
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 ;
BEGIN
   fd := open (ADR (p), O_RDONLY, 0) ;
   IF fd < 0 THEN
      RETURN FALSE
   END ;
   SetSource (p) ;                     (* {$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                             (* ^Z ends the text *)
      ELSIF b = 10 THEN
         IF NOT prevCR THEN
            InsertCh (Length (), CHR (13))  (* lone LF -> CR *)
         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 ;

PROCEDURE ShowAt (pos : CARDINAL) ;
(* print the source around pos, with '^' under pos *)
VAR s, e, i : CARDINAL ;
BEGIN
   IF pos > 40 THEN
      s := pos - 40
   ELSE
      s := 0
   END ;
   e := pos + 30 ;
   IF e > Length () THEN
      e := Length ()
   END ;
   IF e > s + 78 THEN
      e := s + 78
   END ;
   i := 0 ;
   WHILE s + i < e DO
      txt [i] := CharAt (s + i) ;
      IF txt [i] = CHR (13) THEN
         txt [i] := " "
      END ;
      IF s + i = pos THEN
         mark [i] := "^"
      ELSE
         mark [i] := "-"
      END ;
      INC (i)
   END ;
   txt [i] := 0C ;
   mark [i] := 0C ;
   PutStr ("        " ) ;
   PutStr (txt) ;
   NL ;
   PutStr ("        " ) ;
   PutStr (mark) ;
   NL
END ShowAt ;

VAR
   errNo, errPos : CARDINAL ;
   ok : BOOLEAN ;
   dump, image : BOOLEAN ;

PROCEDURE Hex (b : BYTE ; VAR out : ARRAY OF CHAR) ;
(* ISO will not index a plain string constant as an array, so compute the
   two nibbles instead of using a "0123456789ABCDEF" lookup. *)
VAR d : CARDINAL ;
BEGIN
   d := VAL (CARDINAL, b) DIV 16 ;   (* BYTE arith yields BYTE *)
   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) ;
(* one hex digit.  Do NOT reuse Hex for this: Hex formats a BYTE as two
   chars, so printing 4 nibbles through it emits 8 digits and every offset
   reads 16x too large. *)
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) ;
(* 4 hex digits, e.g. "0010" for 16 *)
VAR d : CARDINAL ;
BEGIN
   d := 4096 ;                       (* 16^3, no "**" needed *)
   WHILE d > 0 DO
      PutHexNib ((n DIV d) MOD 16) ;
      d := d DIV 16
   END ;
   PutStr (":  ")
END PutCardHex4 ;

PROCEDURE DumpCode ;
(* hex dump of the emitted PROGRAM, 16 bytes per line.  The runtime is not
   part of the program, so the program starts at 0 and is CodeBytes() long. *)
VAR i, n : CARDINAL ;
    hx : ARRAY [0..1] OF CHAR ;
    b : BYTE ;
BEGIN
   i := 0 ;
   WHILE i < CodeBytes () DO
      PutStr ("        " ) ;
      PutCardHex4 (i) ;
      n := 0 ;
      WHILE (n < 16) AND (i + n < CodeBytes ()) DO
         b := CodeByteAt (i + n) ;
         Hex (b, hx) ;
         PutCh (hx [0]) ;
         PutCh (hx [1]) ;
         PutCh (" ") ;
         INC (n)
      END ;
      NL ;
      i := i + 16
   END
END DumpCode ;

PROCEDURE DumpImage ;
(* The whole linked image - [entry JMP][runtime][program header][program code] -
   which is what a .COM would actually contain.  The runtime's own bytes
   (rtSz below, derived rather than written down) are shown only at the head
   and the tail: enough to prove the blob is really in there, without burying
   the program in 28 lines of library. *)
VAR i, n, rtSz, total, from, lim : CARDINAL ;
    hx : ARRAY [0..1] OF CHAR ;
BEGIN
   rtSz := ImageBytes () - CodeBytes () ;
   total := ImageBytes () ;
   PutStr ("        image=") ;
   PutCard (total) ;
   PutStr ("  rtSz=") ;
   PutCard (rtSz) ;
   PutStr ("  dataBase=") ;
   PutCard (DataBase ()) ;
   PutStr ("  dataEnd=") ;
   PutCard (DataBase () + DataBytes ()) ;
   NL ;
   PutStr ("        rt head " ) ;
   i := 0 ;
   WHILE i < 16 DO
      Hex (ImageByteAt (i), hx) ;
      PutCh (hx [0]) ; PutCh (hx [1]) ; PutCh (" ") ;
      INC (i)
   END ;
   NL ;
   i := rtSz - 16 ;
   WHILE i < total DO
      from := i ;
      lim := total ;
      IF lim > from + 16 THEN
         lim := from + 16
      END ;
      PutStr ("        " ) ;
      PutCardHex4 (from) ;
      n := 0 ;
      WHILE (n < 16) AND (from + n < lim) DO
         Hex (ImageByteAt (from + n), hx) ;
         PutCh (hx [0]) ; PutCh (hx [1]) ; PutCh (" ") ;
         INC (n)
      END ;
      NL ;
      i := i + 16
   END
END DumpImage ;

PROCEDURE IsCmd (c1, c2, c3, c4, c5 : CHAR ) : BOOLEAN ;
(* the line "@word" switches a dump mode on for the rest of the run *)
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 # 6 THEN
      RETURN FALSE
   END ;
   RETURN (lineBuf [1] = c1) AND (lineBuf [2] = c2) AND (lineBuf [3] = c3)
      AND (lineBuf [4] = c4) AND (lineBuf [5] = c5)
END IsCmd ;

BEGIN
   PutStr ("FIXTURE  RESULT") ;
   NL ;
   WHILE ReadLineStr (lineBuf) DO
      IF IsCmd ("d", "u", "m", "p", " ") THEN
         dump := TRUE                    (* "@dump": hex-dump from here on *)
      ELSIF IsCmd ("i", "m", "a", "g", "e") THEN
         image := TRUE                   (* "@image": whole image, layout too *)
      ELSE
         StrCopy (pathCopy, lineBuf) ;
         IF LoadFile (pathCopy) THEN
            ok := Compile (errNo, errPos) ;
            IF ok THEN
               PutStr (lineBuf) ;
               PutStr ("  OK  code=") ;
               PutCard (CodeBytes ()) ;
               PutStr (" data=") ;
               PutCard (DataBytes ()) ;
               NL ;
               IF image THEN
                  DumpImage ()
               ELSIF dump THEN
                  DumpCode ()
               END
            ELSE
               PutStr (lineBuf) ;
               PutStr ("  ERROR ") ;
               PutCard (errNo) ;
               PutStr (" at pos ") ;
               PutCard (errPos) ;
               NL ;
               ShowAt (errPos)
            END
         ELSE
            PutStr (lineBuf) ;
            PutStr ("  CANNOT OPEN") ;
            NL
         END
      END
   END
END CompileTest.