home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / printf.pqs / printf.pas
Encoding:
Pascal/Delphi Source File  |  1985-08-30  |  6.3 KB  |  195 lines
  1. Program PRINTF;
  2.  
  3. {
  4.     By : Darrell Flenniken  70015,143    20 August 85
  5.  
  6.     PRINTF is a program that implements a formatted print routine
  7.     in the style of that in the 'C' language.
  8.  
  9.     The heart of this routine is a 'hack' to allow a variable
  10.     number of arguments and argument types to be passed to a
  11.     Pascal Procedure via a 'string of pointers'.
  12.  
  13.     Use:
  14.        Printf(Device,Control String,_(arg1)+...+_(argn));
  15.  
  16.     Where :
  17.        1.) Device is Con or Lst
  18.        2.) Control String
  19.  
  20.            The Control String contains literal constants and/or print
  21.            formatting control sequences.  Print format control sequences
  22.            are Escaped with a leading '%' and have the following form:
  23.  
  24.               %W:Dd ....... decimal format
  25.               %W:i  ....... integer format
  26.               %W:s  ....... string format
  27.               %W:u  ....... unsigned integer format
  28.               %W:h  ....... hexidecimal (hhhh) format
  29.               %W:b  ....... binary format
  30.               %t    ....... next tab(8) field
  31.               %n    ....... cr/lf pair
  32.               %%    ....... allow printing of %
  33.  
  34.            W = the total field width for argument
  35.            D = decimal precision (reals only)
  36.            W is optional for all types
  37.            :D is required for reals
  38.  
  39.            a '-' following will force left justification in
  40.            field, right justification is the default.
  41.  
  42.        3.) _(arg)
  43.            The '_' function returns a string containing the binary
  44.            address of the arg.  Multiple args are concatenated.
  45.            The '_' was chosen as the function name to keep it short
  46.            and avoid collisions with other identifiers.
  47.  
  48.     NOTES:
  49.          1.)  Very little error checking is performed by these routines.
  50.               Failure to use proper syntax often leads to hung system.
  51.          2.)  MS-DOS Specific, appropriate changes for CP/M can be made
  52.               in '_' and  'GetArg' for 2 Byte Pointers.
  53.  
  54.  
  55.     Enjoy....
  56. }
  57.  
  58.  
  59. TYPE
  60.        String4 = String[4];
  61.        String80 = String[80];
  62.  
  63.  
  64. Function _(VAR Item):String4;
  65. { Return the Address of Item as a String }
  66. BEGIN
  67.      _ := Chr(Lo(Seg(Item)))+Chr(Hi(Seg(Item)))+
  68.            Chr(Lo(Ofs(Item)))+Chr(Hi(Ofs(Item)))
  69. END;
  70.  
  71.  
  72. Procedure PrintF(VAR Dev:Text;Format,ArgVec:String80);
  73. { Print N Items pointed to in ArgVec using Format on Dev [ Con,Lst ] }
  74. CONST
  75.       Hex : Array[0..15] OF Char = '0123456789ABCDEF';
  76. TYPE
  77.       VecPtr = ^VecItem;
  78.       VecItem = RECORD
  79.                    CASE Integer OF
  80.                       1 : (I:Integer);
  81.                       2 : (R:Real);
  82.                       3 : (S:String80);
  83.                 END;
  84. VAR
  85.      Fws,Dps : String[6];
  86.      Fw,Dp,X,E : Integer;
  87.      TOut,LineOut : String[255];
  88.      Left : Boolean;
  89.      Arg : VecPtr;
  90.  
  91. Function GetArg:VecPtr;
  92. { Return a Pointer from ArgVec }
  93. BEGIN
  94.    GetArg := Ptr((Ord(ArgVec[2]) Shl 8) + Ord(ArgVec[1]),
  95.                  (Ord(ArgVec[4]) Shl 8) + Ord(ArgVec[3]));
  96.    Delete(ArgVec,1,4);
  97. END { GetArg };
  98.  
  99. Function SStr(Num:Integer;Ch:Char):String80;
  100. { Return a String of length=Num composed of Char }
  101. VAR
  102.     Temp : String80;
  103. BEGIN
  104.    IF Num <= 0 THEN SStr := '' ELSE BEGIN
  105.       FillChar(Temp[1],Num,Ch);
  106.       Temp[0] := Chr(Num);
  107.       SStr := Temp;
  108.    END;
  109. END { SStr };
  110.  
  111. BEGIN { PrintF }
  112.    X := 1;
  113.    LineOut := '';
  114.    WHILE X < Length(Format) DO BEGIN
  115.       Fws := '0';
  116.       Dps := '0';
  117.       WHILE (Format[X] <> '%') AND (X < Length(Format)) DO BEGIN
  118.          LineOut := LineOut+Format[X];
  119.          X := Succ(X);
  120.       END;
  121.       IF Format[X] = '%' THEN BEGIN
  122.          X := Succ(X);
  123.          IF Format[X] = '-' THEN BEGIN
  124.             Left := TRUE;
  125.             X := Succ(X);
  126.          END ELSE
  127.             Left := FALSE;
  128.          WHILE Format[X] IN ['0'..'9'] DO BEGIN
  129.             Fws := Fws+Format[X];
  130.             X := Succ(X);
  131.          END;
  132.          Val(Fws,Fw,E);
  133.          IF Format[X] = ':' THEN BEGIN
  134.             X := Succ(X);
  135.             WHILE Format[X] IN ['0'..'9'] DO BEGIN
  136.                Dps := Dps+Format[X];
  137.                X := Succ(X);
  138.             END;
  139.          END;
  140.          Val(Dps,Dp,E);
  141.          IF NOT (Format[X] IN ['%','t','n']) THEN
  142.             Arg := GetArg;
  143.          TOut := '';
  144.          CASE Format[X] OF
  145.             's' : TOut := Arg^.S;                              { String }
  146.             'i' : Str(Arg^.I,TOut);                    { Signed Integer }
  147.             'd' : Str(Arg^.R:0:DP,TOut);                      { Decimal }
  148.             'n' : TOut := #13+#10;                              { CR/LF }
  149.             't' : TOut := SStr(8-(Length(LineOut) mod 8),' ');    { Tab }
  150.             'h' : TOut := Hex[Hi(Arg^.I) Shr 4]+                  { Hex }
  151.                           Hex[Hi(Arg^.I) AND $F]+
  152.                           Hex[Lo(Arg^.I) Shr 4]+
  153.                           Hex[Lo(Arg^.I) AND $F];
  154.             'b' : FOR E := 15 DOWNTO 0 DO                      { Binary }
  155.                      TOut := TOut+Chr(((Arg^.I Shr E) AND 1)+$30);
  156.             'u' : IF Arg^.I < 0 THEN                 { Unsigned Integer }
  157.                      Str(Arg^.I+65536.0:0:0,TOut)
  158.                   ELSE
  159.                      Str(Arg^.I,TOut);
  160.             '%' : TOut := '%';                                 { % sign }
  161.          END { CASE };
  162.          IF Left THEN
  163.             LineOut := LineOut+TOut+SStr(Fw-Length(TOut),' ')
  164.          ELSE
  165.             LineOut := LineOut+SStr(Fw-Length(TOut),' ')+TOut;
  166.          X := Succ(X);
  167.       END { IF Format[X] = '%' };
  168.    END { WHILE X < LengthFormat) };
  169.    Write(Dev,LineOut);
  170. END { PrintF };
  171.  
  172. { Examples of Use }
  173.  
  174. VAR
  175.     x,x2,x3,x4 : integer;
  176.     y : real;
  177.     z,Fstr : string[80];
  178.  
  179. BEGIN
  180.    x := 32767;
  181.    x2 := 3;
  182.    x3 := 345;
  183.    x4 := -999;
  184.    y := -999.456;
  185.    z := 'sam i am';
  186.    Fstr := 'test %% %20s %-12i %-:2d %h %b%n';
  187.  
  188.    PrintF(Con,'test %20s %-12i %-12:2d %h %b%n',_(z)+_(x)+_(y)+_(x)+_(x));
  189.    PrintF(Con,'test %-20s %12u %12:2d %h %b%n',_(z)+_(x)+_(y)+_(x)+_(x));
  190.    PrintF(Con,FStr,_(z)+_(x)+_(y)+_(x)+_(x));
  191.    PrintF(Con,'%i%t%i%t%i%t%i',_(x)+_(x2)+_(x3)+_(x4));
  192.    PrintF(Lst,'test %20s %-12i %-12:2d %h %b%n',_(z)+_(x)+_(y)+_(x)+_(x));
  193.    PrintF(Lst,'test %-20s %12i %12:2d %h %b%n',_(z)+_(x)+_(y)+_(x)+_(x));
  194. END.
  195.