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 ;
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 ;
   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 : 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 PutCardHex4 (n : CARDINAL) ;
VAR hx : ARRAY [0..1] OF CHAR ; b : BYTE ; d : CARDINAL ;
BEGIN
   d := 4096 ;                       (* 16^3, no "**" needed *)
   WHILE d > 0 DO
      b := VAL (BYTE, (n DIV d) MOD 16) ;
      Hex (b, hx) ;
      PutCh (hx [0]) ;
      PutCh (hx [1]) ;
      d := d DIV 16
   END ;
   PutStr (":  ")
END PutCardHex4 ;

PROCEDURE DumpCode () ;
(* hex dump of the emitted image, 16 bytes per line *)
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 IsDumpCmd () : BOOLEAN ;
(* the line "@dump" switches the hex dump 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 # 5) OR (lineBuf [1] # "d") OR (lineBuf [2] # "u") OR
      (lineBuf [3] # "m") OR (lineBuf [4] # "p") THEN
      RETURN FALSE
   END ;
   RETURN TRUE
END IsDumpCmd ;

BEGIN
   PutStr ("FIXTURE  RESULT") ;
   NL ;
   WHILE ReadLineStr (lineBuf) DO
      IF IsDumpCmd () THEN
         dump := TRUE                    (* "@dump": hex-dump from here on *)
      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 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.