gcc/m2/gm2-libs/PushBackInput.mod

   1 (* PushBackInput.mod provides a method for pushing back and consuming input.
   2
   3 Copyright (C) 2001-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  *)
  26
  27 IMPLEMENTATION MODULE PushBackInput ;
  28
  29
  30 FROM FIO IMPORT ReadChar, IsNoError, EOF, OpenToRead, WriteChar, StdErr ;
  31 FROM DynamicStrings IMPORT string, Length, char ;
  32 FROM ASCII IMPORT nul, cr, lf ;
  33 FROM Debug IMPORT Halt ;
  34 FROM StrLib IMPORT StrCopy, StrLen ;
  35 FROM NumberIO IMPORT WriteCard ;
  36 FROM StrIO IMPORT WriteString, WriteLn ;
  37 FROM StdIO IMPORT Write, PushOutput, PopOutput ;
  38 FROM libc IMPORT exit ;
  39
  40 IMPORT FIO ;
  41
  42
  43 CONST
  44    MaxPushBackStack =  8192 ;
  45    MaxFileName      =  4096 ;
  46
  47 VAR
  48    FileName  : ARRAY [0..MaxFileName] OF CHAR ;
  49    CharStack : ARRAY [0..MaxPushBackStack] OF CHAR ;
  50    ExitStatus: CARDINAL ;
  51    Column,
  52    StackPtr,
  53    LineNo    : CARDINAL ;
  54    Debugging : BOOLEAN ;
  55
  56
  57 (*
  58    GetCh - gets a character from either the push back stack or
  59            from file, f.
  60 *)
  61
  62 PROCEDURE GetCh (f: File) : CHAR ;
  63 VAR
  64    ch: CHAR ;
  65 BEGIN
  66    IF StackPtr>0
  67    THEN
  68       DEC(StackPtr) ;
  69       IF Debugging
  70       THEN
  71          Write(CharStack[StackPtr])
  72       END ;
  73       RETURN( CharStack[StackPtr] )
  74    ELSE
  75       IF EOF(f) OR (NOT IsNoError(f))
  76       THEN
  77          ch := nul
  78       ELSE
  79          REPEAT
  80             ch := ReadChar(f)
  81          UNTIL (ch#cr) OR EOF(f) OR (NOT IsNoError(f)) ;
  82          IF ch=lf
  83          THEN
  84             Column := 0 ;
  85             INC(LineNo)
  86          ELSE
  87             INC(Column)
  88          END
  89       END ;
  90       IF Debugging
  91       THEN
  92          Write(ch)
  93       END ;
  94       RETURN( ch )
  95    END
  96 END GetCh ;
  97
  98
  99 (*
 100    PutStr - pushes a dynamic string onto the push back stack.
 101             The string, s, is not deallocated.
 102 *)
 103
 104 PROCEDURE PutStr (s: String) ;
 105 VAR
 106    i: CARDINAL ;
 107 BEGIN
 108    i := Length (s) ;
 109    WHILE i > 0 DO
 110       DEC (i) ;
 111       IF PutCh (char (s, i)) # char (s, i)
 112       THEN
 113          Halt('assert failed', __FILE__, __FUNCTION__, __LINE__)
 114       END
 115    END
 116 END PutStr ;
 117
 118
 119 (*
 120    PutString - pushes a string onto the push back stack.
 121 *)
 122
 123 PROCEDURE PutString (a: ARRAY OF CHAR) ;
 124 VAR
 125    l: CARDINAL ;
 126 BEGIN
 127    l := StrLen (a) ;
 128    WHILE l > 0 DO
 129       DEC (l) ;
 130       IF PutCh (a[l]) # a[l]
 131       THEN
 132          Halt ('assert failed', __FILE__, __FUNCTION__, __LINE__)
 133       END
 134    END
 135 END PutString ;
 136
 137
 138 (*
 139    PutCh - pushes a character onto the push back stack, it also
 140            returns the character which has been pushed.
 141 *)
 142
 143 PROCEDURE PutCh (ch: CHAR) : CHAR ;
 144 BEGIN
 145    IF StackPtr<MaxPushBackStack
 146    THEN
 147       CharStack[StackPtr] := ch ;
 148       INC(StackPtr)
 149    ELSE
 150       Halt('max push back stack exceeded, increase MaxPushBackStack',
 151            __FILE__, __FUNCTION__, __LINE__)
 152    END ;
 153    RETURN( ch )
 154 END PutCh ;
 155
 156
 157 (*
 158    Open - opens a file for reading.
 159 *)
 160
 161 PROCEDURE Open (a: ARRAY OF CHAR) : File ;
 162 BEGIN
 163    Init ;
 164    StrCopy(a, FileName) ;
 165    RETURN( OpenToRead(a) )
 166 END Open ;
 167
 168
 169 (*
 170    Close - closes the opened file.
 171 *)
 172
 173 PROCEDURE Close (f: File) ;
 174 BEGIN
 175    FIO.Close(f)
 176 END Close ;
 177
 178
 179 (*
 180    ErrChar - writes a char, ch, to stderr.
 181 *)
 182
 183 PROCEDURE ErrChar (ch: CHAR) ;
 184 BEGIN
 185    WriteChar(StdErr, ch)
 186 END ErrChar ;
 187
 188
 189 (*
 190    Error - emits an error message with the appropriate file, line combination.
 191 *)
 192
 193 PROCEDURE Error (a: ARRAY OF CHAR) ;
 194 BEGIN
 195    PushOutput(ErrChar) ;
 196    WriteString(FileName) ; Write(':') ; WriteCard(LineNo, 0) ; Write(':') ; WriteString(a) ; WriteLn ;
 197    PopOutput ;
 198    FIO.Close(StdErr) ;
 199    exit(1)
 200 END Error ;
 201
 202
 203 (*
 204    WarnError - emits an error message with the appropriate file, line combination.
 205                It does not terminate but when the program finishes an exit status of
 206                1 will be issued.
 207 *)
 208
 209 PROCEDURE WarnError (a: ARRAY OF CHAR) ;
 210 BEGIN
 211    PushOutput(ErrChar) ;
 212    WriteString(FileName) ; Write(':') ; WriteCard(LineNo, 0) ; Write(':') ; WriteString(a) ; WriteLn ;
 213    PopOutput ;
 214    ExitStatus := 1
 215 END WarnError ;
 216
 217
 218 (*
 219    WarnString - emits an error message with the appropriate file, line combination.
 220                 It does not terminate but when the program finishes an exit status of
 221                 1 will be issued.
 222 *)
 223
 224 PROCEDURE WarnString (s: String) ;
 225 VAR
 226    p : POINTER TO CHAR ;
 227 BEGIN
 228    p := string(s) ;
 229    WriteString(FileName) ; Write(':') ; WriteCard(LineNo, 0) ; Write(':') ;
 230    REPEAT
 231       IF p#NIL
 232       THEN
 233          IF p^=lf
 234          THEN
 235             WriteLn ;
 236             WriteString(FileName) ; Write(':') ; WriteCard(LineNo, 0) ; Write(':')
 237          ELSE
 238             Write(p^)
 239          END ;
 240          INC(p)
 241       END ;
 242    UNTIL (p=NIL) OR (p^=nul) ;
 243    ExitStatus := 1
 244 END WarnString ;
 245
 246
 247 (*
 248    GetExitStatus - returns the exit status which will be 1 if any warnings were issued.
 249 *)
 250
 251 PROCEDURE GetExitStatus () : CARDINAL ;
 252 BEGIN
 253    RETURN( ExitStatus )
 254 END GetExitStatus ;
 255
 256
 257 (*
 258    SetDebug - sets the debug flag on or off.
 259 *)
 260
 261 PROCEDURE SetDebug (d: BOOLEAN) ;
 262 BEGIN
 263    Debugging := d
 264 END SetDebug ;
 265
 266
 267 (*
 268    GetColumnPosition - returns the column position of the current character.
 269 *)
 270
 271 PROCEDURE GetColumnPosition () : CARDINAL ;
 272 BEGIN
 273    IF StackPtr>Column
 274    THEN
 275       RETURN( 0 )
 276    ELSE
 277       RETURN( Column-StackPtr )
 278    END
 279 END GetColumnPosition ;
 280
 281
 282 (*
 283    GetCurrentLine - returns the current line number.
 284 *)
 285
 286 PROCEDURE GetCurrentLine () : CARDINAL ;
 287 BEGIN
 288    RETURN( LineNo )
 289 END GetCurrentLine ;
 290
 291
 292 (*
 293    Init - initialize global variables.
 294 *)
 295
 296 PROCEDURE Init ;
 297 BEGIN
 298    ExitStatus := 0 ;
 299    StackPtr   := 0 ;
 300    LineNo     := 1 ;
 301    Column     := 0
 302 END Init ;
 303
 304
 305 BEGIN
 306    SetDebug(FALSE) ;
 307    Init
 308 END PushBackInput.