IMPLEMENTATION MODULE CrudeIO ;

FROM SYSTEM IMPORT TKCALL , ADDRESS , WORD ;
IMPORT IO ;

VAR
   WrchProc                : PROCWORD ;


PROCEDURE RawWrch( Ch : WORD ) ;
BEGIN
   IO.XWriteByte( CARDINAL( Ch ) ) ;
END RawWrch ;


PROCEDURE Wrch( Ch : WORD ) ;
BEGIN
   WrchProc( Ch ) ;
END Wrch ;


PROCEDURE Writeln ;
BEGIN
   WrchProc( 10 ) ;
END Writeln ;


PROCEDURE WriteS( CharArray : ARRAY OF CHAR ) ;
VAR
   I , Length          : CARDINAL ;
   Ch , Ch1 , Ch2      : CHAR ;

   PROCEDURE HexVal( Ch : CHAR ) : INTEGER ;
   BEGIN
      IF ( '0' <= Ch ) AND ( Ch <= '9' ) THEN
         RETURN( ORD( Ch ) - ORD( '0' ) ) ;
      END (* if *) ;
      IF ( 'A' <= Ch ) AND ( Ch <= 'F' ) THEN
         RETURN( ORD( Ch ) - ORD( 'A' ) + 10 ) ;
      END (* if *) ;
      RETURN( -1 ) ;
   END HexVal ;


   PROCEDURE HexChars( Ch1 , Ch2 : CHAR ) ;
   BEGIN
      IF ( HexVal( Ch1 ) < 0 ) OR ( HexVal( Ch2 ) < 0 ) THEN
         WrchProc( '*' ) ;
         WrchProc( Ch1 ) ;
         WrchProc( Ch2 ) ;
      ELSE
         WrchProc( HexVal( Ch1 ) * 16 + HexVal( Ch2 ) ) ;
      END (* if *) ;
   END HexChars ;


BEGIN
   Length := 0 ;
   WHILE ( Length <= HIGH( CharArray ) ) AND ( CharArray[ Length ] <> 0C ) DO
      INC( Length ) ;
   END (* while *) ;
   I := 0 ;
   WHILE I < Length DO
      Ch := CharArray[ I ] ;
      IF Ch = '*' THEN
         INC( I ) ;
         Ch := CharArray[ I ] ;
         CASE Ch OF
         'N' : WrchProc( 10 ) ;
      |  'S' : WrchProc( ' ' ) ;
      |  'T' : WriteS( "   " ) ;
      |  'P' : WrchProc( 14C ) ;
      |  '"' : WrchProc( "'" ) ;
      |  "'" : WrchProc( '"' ) ;
      |  'X' : IF ( I + 2 ) < Length THEN
                  Ch1 := CharArray[ I+1 ] ;
                  Ch2 := CharArray[ I+2 ] ;
                  HexChars( Ch1 , Ch2 ) ;
                  INC( I , 2 ) ;
               ELSE
                  WrchProc( Ch ) ;
               END (* if *) ;
         ELSE
               WrchProc( '*' ) ;
               WrchProc( Ch ) ;
         END (* case *) ;
      ELSE
         WrchProc( Ch ) ;
      END (* if *) ;
      INC( I ) ;
   END (* while *) ;
END WriteS ;


PROCEDURE WriteChar( Ch : WORD ) ;
BEGIN
   IF ( CARDINAL( ' ' ) <= CARDINAL( Ch ) ) AND
      ( CARDINAL( Ch )  <= CARDINAL( '~' ) ) THEN
      Wrch( "'" ) ;
      Wrch( Ch ) ;
      Wrch( "'" ) ;
   ELSE
      Wrch( '[' ) ;
      WriteHex( Ch , 2 ) ;
      Wrch( ']' ) ;
   END (* if *) ;
END WriteChar ;



PROCEDURE WritePointer( P : ADDRESS ) ;
BEGIN
   IF P = NIL THEN
      WriteS( "NIL" ) ;
   ELSE
      WriteHex( P , 8 ) ;
   END (* if *) ;
END WritePointer ;


PROCEDURE WriteSTRING( S : ADDRESS ) ;
(* Writes S as unquoted "NIL" or S^ as quoted "string" *)
VAR
   ArrayOfCharP            : POINTER TO ARRAY [ 0..10000000 ] OF CHAR ;
   I                       : CARDINAL ;
BEGIN
   IF S = NIL THEN
      WriteS( "NIL" ) ;
   ELSE
      WrchProc( '"' ) ;
      ArrayOfCharP := S ;
      I := 0 ;
      WHILE ArrayOfCharP^[ I ] <> 0C DO
         WrchProc( ArrayOfCharP^[ I ] ) ;
         INC( I ) ;
      END (* while *) ;
      WrchProc( '"' ) ;
   END (* if *) ;
END WriteSTRING ;


PROCEDURE WriteBase( Number : WORD ;
                     Base : CARDINAL ;
                     Width : INTEGER ;
                     LeadChar : CHAR ) ;
VAR
   N              : CARDINAL ;
BEGIN
   N := CARDINAL( Number ) ;
   IF N >= Base THEN
      WriteBase( N DIV Base , Base , Width - 1 , LeadChar ) ;
   ELSE
      WHILE Width > 1 DO
         WrchProc( LeadChar ) ;
         DEC( Width ) ;
      END (* while *) ;
   END (* if *) ;
   N := N MOD Base ;
   IF N < 10 THEN
      WrchProc( N + ORD( '0' ) ) ;
   ELSE
      WrchProc( N + ORD( 'A' ) - 10 ) ;
   END (* if *) ;
END WriteBase ;


PROCEDURE WriteHex( Number : WORD ; Width : INTEGER ) ;
BEGIN
   WriteBase( Number , 16 , Width , '0' ) ;
END WriteHex ;


PROCEDURE WriteDec( Number : WORD ; Width : INTEGER ) ;
VAR
   Int            : INTEGER ;
BEGIN
   Int := INTEGER( Number ) ;
   IF INTEGER( Number ) < 0 THEN
      Int := - Int ;
      IF INTEGER( Int ) > 0 THEN
         WrchProc( '-' ) ;
      END (* if *) ;
   END (* if *) ;
   WriteBase( Int , 10 , Width , ' ' ) ;
END WriteDec ;


PROCEDURE WriteH( W : WORD ) ;
BEGIN
   WriteBase( W , 16 , 0 , ' ' ) ;
END WriteH ;


PROCEDURE WriteI( W : WORD ) ;
BEGIN
   WriteDec( W , 0 ) ;
END WriteI ;


PROCEDURE WriteC( W : WORD ) ;
BEGIN
   WriteBase( W , 10 , 0 , ' ' ) ;
END WriteC ;


PROCEDURE WriteB( W : WORD ) ;
BEGIN
   IF CARDINAL( W ) = ORD( TRUE ) THEN
      WriteS( "True " ) ;
   ELSIF CARDINAL( W ) = ORD( FALSE ) THEN
      WriteS( "False" ) ;
   ELSE
      WriteS( "?????" ) ;
   END (* if *) ;
END WriteB ;


PROCEDURE SetElement( Set : WORD ; Element : WORD ; Name : ARRAY OF CHAR ) ;
(* Writes the Name + a space if the Element is IN the Set *)
BEGIN
   IF CARDINAL( Element ) IN BITSET( Set ) THEN
      WriteS( Name ) ;
      WrchProc( ' ' ) ;
   END (* if *) ;
END SetElement ;


PROCEDURE UseWrch( Proc : PROCWORD ) ;
(* Specifies that the given procedure is to be used for subsequent output *)
BEGIN
   WrchProc := Proc ;
END UseWrch ;


BEGIN
   WrchProc := RawWrch ;
END CrudeIO.