Topspeed_JPI/TS-V3/SRC/PRINTFBA.LST

Listing:

    1  (* Release 3.10 *)
    2  (*-------------------------------------------------------------------------*
    3  *                                                                          *
    4  *  PRINTFBA.MOD - COMMS Toolkit formatted i/o support                      *
    5  *                                                                          *
    6  *  COPYRIGHT (C) 1988..1992 Clarion Software Corporation.                  *
    7  *  All Rights Reserved                                                     *
    8  *                                                                          *
    9  *--------------------------------------------------------------------------*)
   10  
   11  IMPLEMENTATION MODULE PrintFBase;
   12    IMPORT Lib,IO;
   13  
   14    CONST
   15      MaxArgs             = 5;
   16      UpperDigits         = '0123456789ABCDEF';
*****                            ^ not supported yet
   17      LowerDigits         = '0123456789abcdef';
*****                            ^ not supported yet
   18  
   19    TYPE
   20      StringPtr           = POINTER TO ARRAY[0..0FFFH] OF CHAR;
*****                                                ^ not supported yet
*****                                                          ^ not supported yet
   21      JustifyTypes        = (Left,Right,Centre);
   22      CardType            = (short,card,long);
   23      CardPointer         = POINTER TO RECORD
   24                              CASE :CardType OF
*****                              ^ not supported yet
*****                                             ^ 'POINTER' expected
   25                                short    : shortp  : SHORTCARD;             |
   26                                card     : cardp   : CARDINAL;              |
   27                                long     : longp   : LONGCARD;              |
   28                              END;
   29                            END;
   30  
   31    VAR
   32      PatAddr,DestAddr    : StringPtr;
   33      NumberBase          : LONGCARD;
   34      ArgNo,ArgCount,Patp,
   35      Destp,PatMax,DestMax: CARDINAL;
   36      ArgList             : ARRAY[0..MaxArgs-1] OF ADDRESS;
   37      Size                : ARRAY[0..MaxArgs-1] OF CARDINAL;
   38      Digits              : ARRAY[0..15] OF CHAR;
   39      Convert             : ARRAY[0..51] OF PROC;
   40  
   41  (*....................................*)
   42  
   43    PROCEDURE Length(VAR s:ARRAY OF CHAR; Max:CARDINAL):CARDINAL;
   44      BEGIN
   45        RETURN Lib.ScanR(ADR(s),Max,0C);
   46      END Length;
   47  
   48  (*....................................*)
   49  
   50    PROCEDURE Justify(Justification:JustifyTypes;VAR dest:ARRAY OF CHAR;Lnth:CARDINAL;PadChar:CHAR):CARDINAL;
   51      VAR
   52        Len               : CARDINAL;
   53      BEGIN
   54        Len := Lib.ScanR(ADR(dest),HIGH(dest)+1,0C);
   55        LOOP
   56          IF Len>=Lnth THEN
   57            EXIT;
   58          END;
   59          IF (Justification=Right) OR (Justification=Centre) THEN
   60            INC(Len);
   61            Lib.Move(ADR(dest),ADR(dest[1]),Len);
   62            dest[0]:=PadChar;
   63          END;
   64          IF Len>=Lnth THEN
   65            EXIT;
   66          END;
   67          IF (Justification=Left) OR (Justification=Centre) THEN
   68            dest[Len]:=PadChar;
   69            INC(Len);
   70            dest[Len]:=0C;
   71          END
   72        END;
   73        RETURN Len;
   74      END Justify;
   75  
   76  (*............................................*)
   77  
   78    PROCEDURE Error(ErrNo:CARDINAL);
   79      VAR
   80        argnumstr         : ARRAY[0..9] OF CHAR;
   81      BEGIN
   82        IO.WrLn;
   83        IO.WrStr('PrintF Error --> ');
   84        CASE ErrNo OF
   85          1               : IO.WrStr('Unexpected end of spec. input.');     |
   86          2               : IO.WrStr('Argument does not match specification.');|
   87          3               : IO.WrStr('Wrong number of args.');              |
   88          4               : IO.WrStr('Not a recognised field specifier');   |
   89          5               : IO.WrStr('Not enough room in dest string.');    |
   90          6               : IO.WrStr('Char codes must be three digits.');   |
   91          7               : IO.WrStr('Width argument must be cardinal.');   |
   92          8               : IO.WrStr('NewConversion, Type Char must be in {a..z, A..Z}');|
   93        END; (* cases *)
   94        IO.WrLn;
   95        HALT;
   96      END Error;
   97  
   98  (*....................................*)
   99  
  100    PROCEDURE CToS(c:LONGCARD; VAR i:CARDINAL);
  101      BEGIN
  102        IF c>=NumberBase THEN
  103          CToS(c DIV NumberBase,i);
  104        END;
  105        DestString[i] := Digits[CARDINAL(c MOD NumberBase)];
  106        INC(i);
  107      END CToS;
  108  
  109  (*....................................*)
  110  
  111    PROCEDURE ReadLong(VAR l:LONGCARD);
  112      VAR
  113        p                 : CardPointer;
  114      BEGIN
  115        p := Data;
  116        IF DataSize=1 THEN
  117          l := LONGCARD(p^.shortp)
  118        ELSIF DataSize=2 THEN
  119          l := LONGCARD(p^.cardp)
  120        ELSIF DataSize=4 THEN
  121          l := p^.longp
  122        ELSE
  123          Error(2);
  124        END;
  125      END ReadLong;
  126  
  127  (*....................................*)
  128  
  129    PROCEDURE CardToString;
  130      (* Handle conversion to string of SHORTCARD,CARDINAL and LONGCARD for*)
  131      (* all number bases from 2-16. Note that only bases 8,10 & 16 are    *)
  132      (* supported by the field spec protocol.                             *)
  133      VAR
  134        i                 : CARDINAL;
  135        c                 : LONGCARD;
  136      BEGIN
  137        IF TypeChar='o' THEN
  138          NumberBase := 8;
  139        ELSIF TypeChar='u' THEN
  140          NumberBase := 10;
  141        ELSE
  142          NumberBase := 16;
  143        END;
  144        ReadLong(c);
  145        i:=0;
  146        IF AlwaysSigned THEN
  147          DestString[0]:=Positive;
  148          INC(i);
  149        END;
  150        CToS(c,i);
  151        DestString[i]:=0C;
  152      END CardToString;
  153  
  154  (*....................................*)
  155  
  156    PROCEDURE LowerCaseHex;
  157      BEGIN
  158        Digits:=LowerDigits;
  159        CardToString;
  160        Digits:=UpperDigits
  161      END LowerCaseHex;
  162  
  163  (*....................................*)
  164  
  165    PROCEDURE IntToString;
  166      (* Handle conversion to string of SHORTINT,INTEGER and LONGINT       *)
  167      VAR
  168        i                 : CARDINAL;
  169        p                 : CardPointer;
  170        x                 : LONGINT;
  171      BEGIN
  172        NumberBase := 10;
  173        p := Data;
  174        IF DataSize=1 THEN
  175          x := LONGINT(SHORTINT(p^.shortp))
  176        ELSIF DataSize=2 THEN
  177          x := LONGINT(INTEGER(p^.cardp))
  178        ELSIF DataSize=4 THEN
  179          x := LONGINT(p^.longp)
  180        ELSE
  181          Error(2);
  182        END;
  183        i:=0;
  184        IF x<0 THEN
  185          DestString[0]:='-'; INC(i); x:=-x
  186        ELSIF AlwaysSigned THEN
  187          DestString[0]:=Positive; INC(i)
  188        END;
  189        CToS(LONGCARD(x),i);
  190        DestString[i]:=0C;
  191      END IntToString;
  192  
  193  (*....................................*)
  194  
  195    PROCEDURE CopyString;
  196      VAR
  197        Lnth              : CARDINAL;
  198        stringp           : StringPtr;
  199      BEGIN
  200        stringp := Data;
  201        Lnth := Length(stringp^,DataSize);
  202        Lib.Move(Data,ADR(DestString),Lnth);
  203        DestString[Lnth] := 0C;
  204      END CopyString;
  205  
  206  (*....................................*)
  207  
  208    PROCEDURE StoreChar(Ch:CHAR);
  209      BEGIN
  210        IF Destp<>DestMax THEN
  211          DestAddr^[Destp] := Ch;
  212          INC(Destp);
  213        END;
  214      END StoreChar;
  215  
  216  (*....................................*)
  217  
  218    PROCEDURE CopyChar;
  219      VAR
  220        charp             : POINTER TO CHAR;
  221      BEGIN
  222        IF DataSize=1 THEN
  223          charp := Data;
  224          DestString[0] := charp^;
  225          DestString[1] := 0C
  226        ELSE
  227          Error(2)
  228        END;
  229      END CopyChar;
  230  
  231  (*....................................*)
  232  
  233    PROCEDURE Parse;
  234      VAR
  235        Ch                : CHAR;
  236  
  237  (*. . . . . . . . . . . . . . . . . . .*)
  238  
  239      PROCEDURE GetChar(VAR Ch:CHAR):BOOLEAN;
  240        BEGIN
  241          IF Patp=PatMax THEN
  242            Ch := 0C;
  243          ELSE
  244            Ch := PatAddr^[Patp];
  245            INC(Patp);
  246          END;
  247          RETURN Ch<>0C;
  248        END GetChar;
  249  
  250  (*. . . . . . . . . . . . . . . . . . .*)
  251  
  252      PROCEDURE NextChar;
  253        BEGIN
  254          IF NOT GetChar(Ch) THEN
  255            Error(1);
  256          END;
  257        END NextChar;
  258  
  259  (*. . . . . . . . . . . . . . . . . . .*)
  260  
  261      PROCEDURE ReadNumber(VAR c:CARDINAL);
  262        VAR
  263          temp            : LONGCARD;
  264        BEGIN
  265          IF Ch='*' THEN
  266            NextChar;
  267            IF ArgNo=ArgCount THEN
  268              Error(3);
  269            END;
  270            Data:=ArgList[ArgNo];
  271            DataSize:=Size[ArgNo];
  272            INC(ArgNo);
  273            ReadLong(temp);
  274            IF temp>255 THEN
  275              Error(7);
  276            ELSE
  277              c:=CARDINAL(temp);
  278            END;
  279          ELSE
  280            c := 0;
  281            WHILE (Ch>='0') AND (Ch<='9') DO
  282              c := c*10 + ORD(Ch)-48;
  283              NextChar;
  284            END;
  285          END;
  286        END ReadNumber;
  287  
  288  (*. . . . . . . . . . . . . . . . . . .*)
  289  
  290      PROCEDURE FieldSpecification;
  291        VAR
  292          Lnth,i          : CARDINAL;
  293          Just            : JustifyTypes;
  294          TestCh          : CHAR;
  295        BEGIN
  296          IF ArgNo=ArgCount THEN
  297            Error(3);
  298          END;
  299          RightJustify:=TRUE;
  300          FieldWidth:=0;
  301          Places:=5;
  302          PadChar:=' ';
  303          AlwaysSigned:=FALSE;
  304          NextChar;
  305          IF Ch='%' THEN
  306            StoreChar(Ch);
  307            RETURN;
  308          END;
  309          LOOP
  310            IF Ch='-' THEN
  311              RightJustify:=FALSE;
  312              NextChar;
  313            ELSIF (Ch='+') OR (Ch=' ') THEN
  314              AlwaysSigned:=TRUE; Positive:=Ch; NextChar
  315            ELSIF Ch='0' THEN
  316              PadChar:='0';
  317              NextChar;
  318            ELSIF (Ch>='1') AND (Ch<='9') THEN
  319              ReadNumber(FieldWidth);
  320              IF Ch='.' THEN
  321                NextChar;
  322                ReadNumber(Places);
  323              END;
  324            ELSE
  325              EXIT;
  326            END;
  327          END;
  328          TestCh := CAP(Ch);
  329          IF (TestCh>='A') AND (TestCh<='Z') THEN
  330            TypeChar := Ch;
  331            IF ArgNo=ArgCount THEN
  332              Error(3);
  333            END;
  334            Data := ArgList[ArgNo];
  335            DataSize := Size[ArgNo];
  336            IF (TypeChar>='a') AND (TypeChar<='z') THEN
  337              i := ORD(TypeChar)-ORD('a')
  338            ELSE
  339              i := 26 + (ORD(TypeChar)-ORD('A'))
  340            END;
  341            IF Convert[i]=NULLPROC THEN
  342              Error(4);
  343            ELSE
  344              Convert[i]();
  345            END;
  346          ELSE
  347            Error(4);
  348          END;
  349          IF RightJustify THEN
  350            Just:=Right;
  351          ELSE
  352            Just:=Left;
  353          END;
  354          Lnth := Justify(Just,DestString,FieldWidth,PadChar);
  355          IF Destp+Lnth>DestMax THEN
  356            Lnth:=DestMax-Destp;
  357          END;
  358          Lib.Move(ADR(DestString),ADR(DestAddr^[Destp]),Lnth);
  359          INC(Destp,Lnth);
  360          INC(ArgNo);
  361        END FieldSpecification;
  362  
  363  (*. . . . . . . . . . . . . . . . . . .*)
  364  
  365      PROCEDURE SwitchChar;
  366        VAR
  367          code,i          : CARDINAL;
  368          c               : CHAR;
  369        BEGIN
  370          NextChar;
  371          CASE CAP(Ch) OF
  372            'B'           : c:=CHR(8);                                      |
  373            'F'           : c:=CHR(12);                                     |
  374            'N'           : StoreChar(CHR(13));
  375                            c:=CHR(10);                                     |
  376            'R'           : c:=CHR(13);                                     |
  377            'T'           : c:=CHR(9);                                      |
  378            '0'..'9'      : code:=ORD(Ch)-48;
  379                            FOR i:=0 TO 1 DO
  380                              NextChar;
  381                              IF (Ch<'0') OR (Ch>'9') THEN
  382                                Error(6);
  383                              END;
  384                              code:=code*10+ORD(Ch)-48;
  385                            END;
  386                            c := CHR(code);                                 |
  387          ELSE
  388            c := Ch
  389          END; (* cases *)
  390          StoreChar(c);
  391        END SwitchChar;
  392  
  393  (*. . . . . . . . . . . . . . . . . . .*)
  394  
  395      BEGIN  (* Parse *)
  396        ArgNo:=0;
  397        WHILE GetChar(Ch) DO
  398          IF Ch='%' THEN
  399            FieldSpecification
  400          ELSIF Ch='\' THEN
  401            SwitchChar
  402          ELSE
  403            StoreChar(Ch);
  404          END;
  405        END;
  406        StoreChar(0C);
  407      END Parse;
  408  
  409  (*...............................................*)
  410  
  411    PROCEDURE DoPrintF(VAR pat:ARRAY OF CHAR;VAR arg1,arg2,arg3,arg4,arg5:ARRAY OF BYTE;VAR dest:ARRAY OF CHAR;NumArgs:CARDINAL);
  412      BEGIN
  413        ArgCount := NumArgs;
  414        PatAddr:=ADR(pat);
  415        Patp:=0;
  416        PatMax:=HIGH(pat)+1;
  417        DestAddr:=ADR(dest);
  418        Destp:=0;
  419        DestMax:=HIGH(dest)+1;
  420        ArgList[0]:=ADR(arg1);
  421        Size[0]:=HIGH(arg1)+1;
  422        ArgList[1]:=ADR(arg2);
  423        Size[1]:=HIGH(arg2)+1;
  424        ArgList[2]:=ADR(arg3);
  425        Size[2]:=HIGH(arg3)+1;
  426        ArgList[3]:=ADR(arg4);
  427        Size[3]:=HIGH(arg4)+1;
  428        ArgList[4]:=ADR(arg5);
  429        Size[4]:=HIGH(arg5)+1;
  430        Digits := UpperDigits;
  431        Parse;
  432      END DoPrintF;
  433  
  434  (*...............................................*)
  435  
  436    PROCEDURE NewConversion(TypeChar:CHAR; ConvertRoutine:PROC);
  437      VAR
  438        i                 : CARDINAL;
  439      BEGIN
  440        IF (CAP(TypeChar)>='A') AND (CAP(TypeChar)<='Z') THEN
  441          IF (TypeChar>='a') AND (TypeChar<='z') THEN
  442            i := ORD(TypeChar)-ORD('a')
  443          ELSE
  444            i := 26 + (ORD(TypeChar)-ORD('A'))
  445          END;
  446          Convert[i] := ConvertRoutine
  447        ELSE
  448          Error(8);
  449        END;
  450      END NewConversion;
  451  
  452  (*..................................................*)
  453  
  454    PROCEDURE InitPrintF;
  455      VAR
  456        i                 : CARDINAL;
  457      BEGIN
  458        FOR i:=0 TO 51 DO
  459          Convert[i]:=PROC(NIL)
  460        END;
  461        NewConversion('i',IntToString);
  462        NewConversion('u',CardToString);
  463        NewConversion('H',CardToString);
  464        NewConversion('h',LowerCaseHex);
  465        NewConversion('X',CardToString);
  466        NewConversion('x',LowerCaseHex);
  467        NewConversion('o',CardToString);
  468        NewConversion('c',CopyChar);
  469        NewConversion('s',CopyString);
  470      END InitPrintF;
  471  
  472  (*..................................................*)
  473  
  474    BEGIN
  475      InitPrintF;
  476    END PrintFBase.
  477  

    6 errors