TP3/shell/tests/RtProbe.mod

MODULE RtProbe ;

(* Dump the assembled runtime: size, entry offsets, hex.  Kept separate from
   CompileTest so the library can be checked on its own, before the compiler
   is wired to it.

   The IMAGE OFFSET the blob will occupy is read from the first line of stdin,
   as a decimal number.  "0" - or no input at all, which is what every
   standalone caller gives it - reproduces the original behaviour: entries and
   internal data addresses come out blob-relative, which is what
   check_runtime.py, rt_exec.py and tests/runtime.golden all want.

   The parameter exists because the base is not cosmetic.  FixUp bakes
   dataAt + rtBase + val + LoadBias into every absolute data address the
   library contains, so a blob built for base 0 and then copied to image
   offset 0x200 has every string pointer 0x200 too low - and that failure is
   silent: wrln would walk a $-terminated string from the wrong place and keep
   going through whatever bytes it finds.  Emitting the bytes is base
   independent; only the addresses are not. *)

FROM Posix IMPORT read, write ;
FROM Runtime IMPORT RT_Build, RT_Size, RT_Byte, RT_Entry, RT_CodeEnd ;
FROM SYSTEM IMPORT ADR, BYTE ;

VAR
   c : CHAR ;

PROCEDURE GetBase () : CARDINAL ;
(* First line of stdin, decimal.  0 on EOF, on a line that is not a number, or
   on no input at all - so a caller that passes nothing gets base 0 and the
   historical output.  One byte at a time, because a line is short and this
   keeps the module free of buffering that could swallow a caller's stdin. *)
VAR
   ch : BYTE ;
   v : CARDINAL ;
   r : LONGINT ;
   more : BOOLEAN ;
BEGIN
   v := 0 ;
   more := TRUE ;
   WHILE more DO
      r := read (0, ADR (ch), 1) ;
      IF r # 1 THEN
         more := FALSE
      ELSIF (ch < 48) OR (ch > 57) THEN
         more := FALSE                (* newline, or junk: the line ends *)
      ELSE
         (* VAL, because ISO Modula-2 has no arithmetic between a BYTE and a
            CARDINAL, and a plain `ch - 48' is exactly the sort of
            mixed-size expression that silently wraps when it is small. *)
         v := v * 10 + (VAL (CARDINAL, ch) - 48)
      END
   END ;
   RETURN v
END GetBase ;

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

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

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

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

PROCEDURE PHEX (b : CARDINAL ) ;
VAR d : CARDINAL ;
BEGIN
   d := b DIV 16 ;
   IF d < 10 THEN PC (CHR (ORD ("0") + d)) ELSE PC (CHR (ORD ("A") + d - 10)) END ;
   d := b MOD 16 ;
   IF d < 10 THEN PC (CHR (ORD ("0") + d)) ELSE PC (CHR (ORD ("A") + d - 10)) END
END PHEX ;

PROCEDURE PENT (i : CARDINAL ; name : ARRAY OF CHAR ) ;
BEGIN
   PS ("  entry ") ; PCARD (i) ; PS (" = ") ; PCARD (RT_Entry (i)) ;
   PS ("  (") ; PS (name) ; PS (")") ; NL
END PENT ;

PROCEDURE Main ;
VAR i, n, base : CARDINAL ;
    names : ARRAY [0..13] OF ARRAY [0..15] OF CHAR ;
BEGIN
   base := GetBase () ;
   RT_Build (base) ;
   (* "base=0" is printed even when it is 0, because a caller that forgets to
      redirect stdin would otherwise get base 0 by accident and no evidence of
      it.  The entries below are then IMAGE-ABSOLUTE, and the last one line
      gives the address the one-character pushback slot lives at, so a harness
      that needs to clear it does not have to recompute FixUp's arithmetic. *)
   PS ("base=") ; PCARD (base) ; NL ;
   PCARD (RT_Size ()) ; PS (" bytes") ; NL ;
   PS ("code ends at ") ; PCARD (RT_CodeEnd ()) ; NL ;
   i := 0 ;
   WHILE i <= 13 DO
      names [i] := "" ;
      INC (i)
   END ;
   names [0] := "initmem" ;  names [1] := "progend" ; names [2] := "stackchk" ;
   names [3] := "wrint" ;   names [4] := "wrchar" ;  names [5] := "wrbool" ;
   names [6] := "wrreal" ;  names [7] := "wrln" ;    names [8] := "rdint" ;
   names [9] := "rdchar" ;  names [10] := "rdbool" ; names [11] := "rdln" ;
   names [12] := "halt" ;   names [13] := "wrtinl" ;
   i := 0 ;
   WHILE i <= 13 DO
      PENT (i, names [i]) ;
      INC (i)
   END ;
   PS ("  hex:") ; NL ;
   i := 0 ;
   WHILE i < RT_Size () DO
      (* eight hex digits of the 32-bit offset, one byte per PHEX call
         (PHEX prints two digits), most significant byte first *)
      PHEX ((i DIV 16777216) MOD 256) ;
      PHEX ((i DIV 65536) MOD 256) ;
      PHEX ((i DIV 256) MOD 256) ;
      PHEX (i MOD 256) ;
      PS ("  ") ;
      n := 0 ;
      WHILE (n < 16) AND (i + n < RT_Size ()) DO
         PHEX (VAL (CARDINAL, RT_Byte (i + n))) ;
         PC (" ") ;
         INC (n)
      END ;
      NL ;
      i := i + 16
   END
END Main ;

BEGIN
   Main
END RtProbe.