Topspeed_JPI/TS-V3/SRC/PRINTFBA.MOD

(* Release 3.10 *)
(*-------------------------------------------------------------------------*
*                                                                          *
*  PRINTFBA.MOD - COMMS Toolkit formatted i/o support                      *
*                                                                          *
*  COPYRIGHT (C) 1988..1992 Clarion Software Corporation.                  *
*  All Rights Reserved                                                     *
*                                                                          *
*--------------------------------------------------------------------------*)

IMPLEMENTATION MODULE PrintFBase;
  IMPORT Lib,IO;

  CONST
    MaxArgs             = 5;
    UpperDigits         = '0123456789ABCDEF';
    LowerDigits         = '0123456789abcdef';

  TYPE
    StringPtr           = POINTER TO ARRAY[0..0FFFH] OF CHAR;
    JustifyTypes        = (Left,Right,Centre);
    CardType            = (short,card,long);
    CardPointer         = POINTER TO RECORD
                            CASE :CardType OF
                              short    : shortp  : SHORTCARD;             |
                              card     : cardp   : CARDINAL;              |
                              long     : longp   : LONGCARD;              |
                            END;
                          END;

  VAR
    PatAddr,DestAddr    : StringPtr;
    NumberBase          : LONGCARD;
    ArgNo,ArgCount,Patp,
    Destp,PatMax,DestMax: CARDINAL;
    ArgList             : ARRAY[0..MaxArgs-1] OF ADDRESS;
    Size                : ARRAY[0..MaxArgs-1] OF CARDINAL;
    Digits              : ARRAY[0..15] OF CHAR;
    Convert             : ARRAY[0..51] OF PROC;

(*....................................*)

  PROCEDURE Length(VAR s:ARRAY OF CHAR; Max:CARDINAL):CARDINAL;
    BEGIN
      RETURN Lib.ScanR(ADR(s),Max,0C);
    END Length;

(*....................................*)

  PROCEDURE Justify(Justification:JustifyTypes;VAR dest:ARRAY OF CHAR;Lnth:CARDINAL;PadChar:CHAR):CARDINAL;
    VAR
      Len               : CARDINAL;
    BEGIN
      Len := Lib.ScanR(ADR(dest),HIGH(dest)+1,0C);
      LOOP
        IF Len>=Lnth THEN
          EXIT;
        END;
        IF (Justification=Right) OR (Justification=Centre) THEN
          INC(Len);
          Lib.Move(ADR(dest),ADR(dest[1]),Len);
          dest[0]:=PadChar;
        END;
        IF Len>=Lnth THEN
          EXIT;
        END;
        IF (Justification=Left) OR (Justification=Centre) THEN
          dest[Len]:=PadChar;
          INC(Len);
          dest[Len]:=0C;
        END
      END;
      RETURN Len;
    END Justify;

(*............................................*)

  PROCEDURE Error(ErrNo:CARDINAL);
    VAR
      argnumstr         : ARRAY[0..9] OF CHAR;
    BEGIN
      IO.WrLn;
      IO.WrStr('PrintF Error --> ');
      CASE ErrNo OF
        1               : IO.WrStr('Unexpected end of spec. input.');     |
        2               : IO.WrStr('Argument does not match specification.');|
        3               : IO.WrStr('Wrong number of args.');              |
        4               : IO.WrStr('Not a recognised field specifier');   |
        5               : IO.WrStr('Not enough room in dest string.');    |
        6               : IO.WrStr('Char codes must be three digits.');   |
        7               : IO.WrStr('Width argument must be cardinal.');   |
        8               : IO.WrStr('NewConversion, Type Char must be in {a..z, A..Z}');|
      END; (* cases *)
      IO.WrLn;
      HALT;
    END Error;

(*....................................*)

  PROCEDURE CToS(c:LONGCARD; VAR i:CARDINAL);
    BEGIN
      IF c>=NumberBase THEN
        CToS(c DIV NumberBase,i);
      END;
      DestString[i] := Digits[CARDINAL(c MOD NumberBase)];
      INC(i);
    END CToS;

(*....................................*)

  PROCEDURE ReadLong(VAR l:LONGCARD);
    VAR
      p                 : CardPointer;
    BEGIN
      p := Data;
      IF DataSize=1 THEN
        l := LONGCARD(p^.shortp)
      ELSIF DataSize=2 THEN
        l := LONGCARD(p^.cardp)
      ELSIF DataSize=4 THEN
        l := p^.longp
      ELSE
        Error(2);
      END;
    END ReadLong;

(*....................................*)

  PROCEDURE CardToString;
    (* Handle conversion to string of SHORTCARD,CARDINAL and LONGCARD for*)
    (* all number bases from 2-16. Note that only bases 8,10 & 16 are    *)
    (* supported by the field spec protocol.                             *)
    VAR
      i                 : CARDINAL;
      c                 : LONGCARD;
    BEGIN
      IF TypeChar='o' THEN
        NumberBase := 8;
      ELSIF TypeChar='u' THEN
        NumberBase := 10;
      ELSE
        NumberBase := 16;
      END;
      ReadLong(c);
      i:=0;
      IF AlwaysSigned THEN
        DestString[0]:=Positive;
        INC(i);
      END;
      CToS(c,i);
      DestString[i]:=0C;
    END CardToString;

(*....................................*)

  PROCEDURE LowerCaseHex;
    BEGIN
      Digits:=LowerDigits;
      CardToString;
      Digits:=UpperDigits
    END LowerCaseHex;

(*....................................*)

  PROCEDURE IntToString;
    (* Handle conversion to string of SHORTINT,INTEGER and LONGINT       *)
    VAR
      i                 : CARDINAL;
      p                 : CardPointer;
      x                 : LONGINT;
    BEGIN
      NumberBase := 10;
      p := Data;
      IF DataSize=1 THEN
        x := LONGINT(SHORTINT(p^.shortp))
      ELSIF DataSize=2 THEN
        x := LONGINT(INTEGER(p^.cardp))
      ELSIF DataSize=4 THEN
        x := LONGINT(p^.longp)
      ELSE
        Error(2);
      END;
      i:=0;
      IF x<0 THEN
        DestString[0]:='-'; INC(i); x:=-x
      ELSIF AlwaysSigned THEN
        DestString[0]:=Positive; INC(i)
      END;
      CToS(LONGCARD(x),i);
      DestString[i]:=0C;
    END IntToString;

(*....................................*)

  PROCEDURE CopyString;
    VAR
      Lnth              : CARDINAL;
      stringp           : StringPtr;
    BEGIN
      stringp := Data;
      Lnth := Length(stringp^,DataSize);
      Lib.Move(Data,ADR(DestString),Lnth);
      DestString[Lnth] := 0C;
    END CopyString;

(*....................................*)

  PROCEDURE StoreChar(Ch:CHAR);
    BEGIN
      IF Destp<>DestMax THEN
        DestAddr^[Destp] := Ch;
        INC(Destp);
      END;
    END StoreChar;

(*....................................*)

  PROCEDURE CopyChar;
    VAR
      charp             : POINTER TO CHAR;
    BEGIN
      IF DataSize=1 THEN
        charp := Data;
        DestString[0] := charp^;
        DestString[1] := 0C
      ELSE
        Error(2)
      END;
    END CopyChar;

(*....................................*)

  PROCEDURE Parse;
    VAR
      Ch                : CHAR;

(*. . . . . . . . . . . . . . . . . . .*)

    PROCEDURE GetChar(VAR Ch:CHAR):BOOLEAN;
      BEGIN
        IF Patp=PatMax THEN
          Ch := 0C;
        ELSE
          Ch := PatAddr^[Patp];
          INC(Patp);
        END;
        RETURN Ch<>0C;
      END GetChar;

(*. . . . . . . . . . . . . . . . . . .*)

    PROCEDURE NextChar;
      BEGIN
        IF NOT GetChar(Ch) THEN
          Error(1);
        END;
      END NextChar;

(*. . . . . . . . . . . . . . . . . . .*)

    PROCEDURE ReadNumber(VAR c:CARDINAL);
      VAR
        temp            : LONGCARD;
      BEGIN
        IF Ch='*' THEN
          NextChar;
          IF ArgNo=ArgCount THEN
            Error(3);
          END;
          Data:=ArgList[ArgNo];
          DataSize:=Size[ArgNo];
          INC(ArgNo);
          ReadLong(temp);
          IF temp>255 THEN
            Error(7);
          ELSE
            c:=CARDINAL(temp);
          END;
        ELSE
          c := 0;
          WHILE (Ch>='0') AND (Ch<='9') DO
            c := c*10 + ORD(Ch)-48;
            NextChar;
          END;
        END;
      END ReadNumber;

(*. . . . . . . . . . . . . . . . . . .*)

    PROCEDURE FieldSpecification;
      VAR
        Lnth,i          : CARDINAL;
        Just            : JustifyTypes;
        TestCh          : CHAR;
      BEGIN
        IF ArgNo=ArgCount THEN
          Error(3);
        END;
        RightJustify:=TRUE;
        FieldWidth:=0;
        Places:=5;
        PadChar:=' ';
        AlwaysSigned:=FALSE;
        NextChar;
        IF Ch='%' THEN
          StoreChar(Ch);
          RETURN;
        END;
        LOOP
          IF Ch='-' THEN
            RightJustify:=FALSE;
            NextChar;
          ELSIF (Ch='+') OR (Ch=' ') THEN
            AlwaysSigned:=TRUE; Positive:=Ch; NextChar
          ELSIF Ch='0' THEN
            PadChar:='0';
            NextChar;
          ELSIF (Ch>='1') AND (Ch<='9') THEN
            ReadNumber(FieldWidth);
            IF Ch='.' THEN
              NextChar;
              ReadNumber(Places);
            END;
          ELSE
            EXIT;
          END;
        END;
        TestCh := CAP(Ch);
        IF (TestCh>='A') AND (TestCh<='Z') THEN
          TypeChar := Ch;
          IF ArgNo=ArgCount THEN
            Error(3);
          END;
          Data := ArgList[ArgNo];
          DataSize := Size[ArgNo];
          IF (TypeChar>='a') AND (TypeChar<='z') THEN
            i := ORD(TypeChar)-ORD('a')
          ELSE
            i := 26 + (ORD(TypeChar)-ORD('A'))
          END;
          IF Convert[i]=NULLPROC THEN
            Error(4);
          ELSE
            Convert[i]();
          END;
        ELSE
          Error(4);
        END;
        IF RightJustify THEN
          Just:=Right;
        ELSE
          Just:=Left;
        END;
        Lnth := Justify(Just,DestString,FieldWidth,PadChar);
        IF Destp+Lnth>DestMax THEN
          Lnth:=DestMax-Destp;
        END;
        Lib.Move(ADR(DestString),ADR(DestAddr^[Destp]),Lnth);
        INC(Destp,Lnth);
        INC(ArgNo);
      END FieldSpecification;

(*. . . . . . . . . . . . . . . . . . .*)

    PROCEDURE SwitchChar;
      VAR
        code,i          : CARDINAL;
        c               : CHAR;
      BEGIN
        NextChar;
        CASE CAP(Ch) OF
          'B'           : c:=CHR(8);                                      |
          'F'           : c:=CHR(12);                                     |
          'N'           : StoreChar(CHR(13));
                          c:=CHR(10);                                     |
          'R'           : c:=CHR(13);                                     |
          'T'           : c:=CHR(9);                                      |
          '0'..'9'      : code:=ORD(Ch)-48;
                          FOR i:=0 TO 1 DO
                            NextChar;
                            IF (Ch<'0') OR (Ch>'9') THEN
                              Error(6);
                            END;
                            code:=code*10+ORD(Ch)-48;
                          END;
                          c := CHR(code);                                 |
        ELSE
          c := Ch
        END; (* cases *)
        StoreChar(c);
      END SwitchChar;

(*. . . . . . . . . . . . . . . . . . .*)

    BEGIN  (* Parse *)
      ArgNo:=0;
      WHILE GetChar(Ch) DO
        IF Ch='%' THEN
          FieldSpecification
        ELSIF Ch='\' THEN
          SwitchChar
        ELSE
          StoreChar(Ch);
        END;
      END;
      StoreChar(0C);
    END Parse;

(*...............................................*)

  PROCEDURE DoPrintF(VAR pat:ARRAY OF CHAR;VAR arg1,arg2,arg3,arg4,arg5:ARRAY OF BYTE;VAR dest:ARRAY OF CHAR;NumArgs:CARDINAL);
    BEGIN
      ArgCount := NumArgs;
      PatAddr:=ADR(pat);
      Patp:=0;
      PatMax:=HIGH(pat)+1;
      DestAddr:=ADR(dest);
      Destp:=0;
      DestMax:=HIGH(dest)+1;
      ArgList[0]:=ADR(arg1);
      Size[0]:=HIGH(arg1)+1;
      ArgList[1]:=ADR(arg2);
      Size[1]:=HIGH(arg2)+1;
      ArgList[2]:=ADR(arg3);
      Size[2]:=HIGH(arg3)+1;
      ArgList[3]:=ADR(arg4);
      Size[3]:=HIGH(arg4)+1;
      ArgList[4]:=ADR(arg5);
      Size[4]:=HIGH(arg5)+1;
      Digits := UpperDigits;
      Parse;
    END DoPrintF;

(*...............................................*)

  PROCEDURE NewConversion(TypeChar:CHAR; ConvertRoutine:PROC);
    VAR
      i                 : CARDINAL;
    BEGIN
      IF (CAP(TypeChar)>='A') AND (CAP(TypeChar)<='Z') THEN
        IF (TypeChar>='a') AND (TypeChar<='z') THEN
          i := ORD(TypeChar)-ORD('a')
        ELSE
          i := 26 + (ORD(TypeChar)-ORD('A'))
        END;
        Convert[i] := ConvertRoutine
      ELSE
        Error(8);
      END;
    END NewConversion;

(*..................................................*)

  PROCEDURE InitPrintF;
    VAR
      i                 : CARDINAL;
    BEGIN
      FOR i:=0 TO 51 DO
        Convert[i]:=PROC(NIL)
      END;
      NewConversion('i',IntToString);
      NewConversion('u',CardToString);
      NewConversion('H',CardToString);
      NewConversion('h',LowerCaseHex);
      NewConversion('X',CardToString);
      NewConversion('x',LowerCaseHex);
      NewConversion('o',CardToString);
      NewConversion('c',CopyChar);
      NewConversion('s',CopyString);
    END InitPrintF;

(*..................................................*)

  BEGIN
    InitPrintF;
  END PrintFBase.