gpcp/GPText.cp

   1 (* ============================================================ *)
   2 (*                                                              *)
   3 (*         Gardens Point Component Pascal Library Module.       *)
   4 (*         Copyright (c) K John Gough 1999, 2000                *)
   5 (*         Created : 26 December 1999 kjg                       *)
   6 (*                                                              *)
   7 (* ============================================================ *)
   8 MODULE GPText;
   9
  10   IMPORT
  11         Console,
  12         T := GPTextFiles;
  13
  14   CONST CWd = 24;
  15   TYPE  CVS = ARRAY CWd OF CHAR;
  16
  17   PROCEDURE Write*(f : T.FILE; c : CHAR);
  18   (** Write a single character to file f. *)
  19   BEGIN
  20     T.WriteChar(f,c);
  21   END Write;
  22
  23   PROCEDURE WriteLn*(f : T.FILE);
  24   (** Write an end of line to file f. *)
  25   BEGIN
  26     T.WriteEOL(f);
  27   END WriteLn;
  28
  29   PROCEDURE WriteString*(f : T.FILE; IN s : ARRAY OF CHAR);
  30   (** Write a character string to file f. *)
  31     VAR l : INTEGER;
  32   BEGIN
  33     l := LEN(s$);
  34     T.WriteNChars(f,s,l);
  35   END WriteString;
  36
  37   PROCEDURE WriteFiller*(f: T.FILE; IN s: ARRAY OF CHAR; c: CHAR; w: INTEGER);
  38   (** Write s left-justified in a field of width w, fill with char c. *)
  39     VAR l : INTEGER;
  40         i : INTEGER;
  41   BEGIN
  42     l := LEN(s$);
  43     IF l < w THEN
  44       T.WriteNChars(f,s,l);
  45       FOR i := l TO w-1 DO T.WriteChar(f,c) END;
  46     ELSE
  47       T.WriteNChars(f,s,w);
  48     END;
  49   END WriteFiller;
  50
  51   PROCEDURE WriteRight(f : T.FILE; IN arr : CVS; sig,wid : INTEGER);
  52     VAR i : INTEGER;
  53         high : INTEGER;
  54   BEGIN
  55     IF wid = 0 THEN
  56       T.WriteChar(f," ");
  57     ELSIF sig < wid THEN (* fill *)
  58       FOR i := 1 TO wid-sig DO T.WriteChar(f," ") END;
  59     END;
  60     FOR i := CWd - sig TO CWd-1 DO T.WriteChar(f,arr[i]) END;
  61   END WriteRight;
  62
  63   PROCEDURE FormatL(n : LONGINT; OUT str : CVS; OUT sig : INTEGER);
  64     VAR idx : INTEGER;
  65         neg : BOOLEAN;
  66         big : BOOLEAN;
  67   BEGIN
  68     big := (n = MIN(LONGINT));
  69     IF big THEN n := n+1 END; (* boot compiler gets INC(long) wrong! *)
  70     neg := (n < 0);
  71     IF neg THEN n := -n END; (* MININT is OK! *)
  72     idx := CWd;
  73     REPEAT
  74       DEC(idx);
  75       str[idx] := CHR(n MOD 10 + ORD('0'));
  76       n := n DIV 10;
  77     UNTIL n = 0;
  78     IF neg THEN DEC(idx); str[idx] := '-' END;
  79     IF big THEN str[CWd-1] := CHR(ORD(str[CWd-1]) + 1) END;
  80     sig := CWd - idx;
  81   END FormatL;
  82
  83   PROCEDURE FormatI(n : INTEGER; OUT str : CVS; OUT sig : INTEGER);
  84     VAR idx : INTEGER;
  85         neg : BOOLEAN;
  86   BEGIN
  87     IF n = MIN(INTEGER) THEN FormatL(n, str, sig); RETURN END;
  88     neg := (n < 0);
  89     IF neg THEN n := -n END;
  90     idx := CWd;
  91     REPEAT
  92       DEC(idx);
  93       str[idx] := CHR(n MOD 10 + ORD('0'));
  94       n := n DIV 10;
  95     UNTIL n = 0;
  96     IF neg THEN DEC(idx); str[idx] := '-' END;
  97     sig := CWd - idx;
  98   END FormatI;
  99
 100   PROCEDURE WriteInt*(f : T.FILE; n : INTEGER; w : INTEGER);
 101   (** Write an integer to file f to a field of width w;
 102       if w = 0, then leave a space then left justify. *)
 103     VAR str : CVS;
 104         sig : INTEGER;
 105   BEGIN
 106     IF w < 0 THEN w := 0 END;
 107     FormatI(n, str, sig);
 108     WriteRight(f, str, sig, w);
 109   END WriteInt;
 110
 111   PROCEDURE IntToStr*(n : INTEGER; OUT a : ARRAY OF CHAR);
 112   (** Format an integer into the character array a. *)
 113     VAR str : CVS;
 114         idx : INTEGER;
 115         sig : INTEGER;
 116   BEGIN
 117     FormatI(n, str, sig);
 118     IF sig < LEN(a) THEN
 119       FOR idx := 0 TO sig-1 DO a[idx] := str[CWd-sig+idx] END;
 120       a[sig] := 0X;
 121     ELSE
 122       FOR idx := 0 TO LEN(a) - 2 DO a[idx] := '*' END;
 123       a[LEN(a)-1] := 0X;
 124     END;
 125   END IntToStr;
 126
 127   PROCEDURE WriteLong*(f : T.FILE; n : LONGINT; w : INTEGER);
 128   (** Write an longint to file f to a field of width w;
 129       if w = 0, then leave a space then left justify. *)
 130     VAR str : CVS;
 131         sig : INTEGER;
 132   BEGIN
 133     IF w < 0 THEN w := 0 END;
 134     FormatL(n, str, sig);
 135     WriteRight(f, str, sig, w);
 136   END WriteLong;
 137
 138   PROCEDURE LongToStr*(n : LONGINT; OUT a : ARRAY OF CHAR);
 139   (** Format a long integer into the character array a. *)
 140     VAR str : CVS;
 141         idx : INTEGER;
 142         sig : INTEGER;
 143   BEGIN
 144     FormatL(n, str, sig);
 145     IF sig < LEN(a) THEN
 146       FOR idx := 0 TO sig-1 DO a[idx] := str[CWd-sig+idx] END;
 147       a[sig] := 0X;
 148     ELSE
 149       FOR idx := 0 TO LEN(a) - 2 DO a[idx] := '*' END;
 150       a[LEN(a)-1] := 0X;
 151     END;
 152   END LongToStr;
 153
 154   PROCEDURE Assign*(IN r : ARRAY OF CHAR; OUT l : ARRAY OF CHAR);
 155     VAR i : INTEGER; lh,rh : INTEGER;
 156   BEGIN
 157     rh := LEN(r$) - 1;          (* string high-val, not including nul *)
 158     lh := LEN(l) - 2;           (* array capacity, with space for nul *)
 159     lh := MIN(lh,rh);
 160     FOR i := 0 TO lh DO l[i] := r[i] END;
 161     l[lh+1] := 0X;
 162   END Assign;
 163
 164 END GPText.