gcc/m2/gm2-libs/M2RTS.mod

   1 (* M2RTS.mod Implements the run time system facilities of Modula-2.
   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 M2RTS ;
  28
  29
  30 FROM libc IMPORT abort, exit, write, getenv, printf, strlen ;
  31 (* FROM Builtins IMPORT strncmp, strcmp ;  not available during bootstrap.  *)
  32 FROM NumberIO IMPORT CardToStr ;
  33 FROM StrLib IMPORT StrCopy, StrLen, StrEqual ;
  34 FROM SYSTEM IMPORT ADR ;
  35 FROM ASCII IMPORT nl, nul ;
  36 FROM Storage IMPORT ALLOCATE ;
  37
  38 IMPORT RTExceptions ;
  39 IMPORT M2EXCEPTION ;
  40 IMPORT M2Dependent ;
  41
  42 CONST
  43    stderrFd = 2 ;
  44
  45 TYPE
  46    PtrToChar = POINTER TO CHAR ;
  47
  48    ProcedureList = RECORD
  49                       head, tail: ProcedureChain
  50                    END ;
  51
  52    ProcedureChain = POINTER TO RECORD
  53                                   p   : PROC ;
  54                                   prev,
  55                                   next: ProcedureChain ;
  56                                 END ;
  57
  58
  59 VAR
  60    InitialProc,
  61    TerminateProc: ProcedureList ;
  62    ExitValue    : INTEGER ;
  63    isHalting,
  64    CallExit     : BOOLEAN ;
  65    Initialized  : BOOLEAN ;
  66
  67
  68 (*
  69    ConstructModules - resolve dependencies and then call each
  70                       module constructor in turn.
  71 *)
  72
  73 PROCEDURE ConstructModules (applicationmodule, libname: ADDRESS;
  74                             overrideliborder: ADDRESS;
  75                             argc: INTEGER; argv, envp: ADDRESS) ;
  76 BEGIN
  77    M2Dependent.ConstructModules (applicationmodule, libname,
  78                                  overrideliborder,
  79                                  argc, argv, envp)
  80 END ConstructModules ;
  81
  82
  83 (*
  84    DeconstructModules - resolve dependencies and then call each
  85                         module constructor in turn.
  86 *)
  87
  88 PROCEDURE DeconstructModules (applicationmodule, libname: ADDRESS;
  89                               argc: INTEGER; argv, envp: ADDRESS) ;
  90 BEGIN
  91    M2Dependent.DeconstructModules (applicationmodule, libname,
  92                                    argc, argv, envp)
  93 END DeconstructModules ;
  94
  95
  96 (*
  97    RegisterModule - adds module name to the list of outstanding
  98                     modules which need to have their dependencies
  99                     explored to determine initialization order.
 100 *)
 101
 102 PROCEDURE RegisterModule (name, libname: ADDRESS;
 103                           init, fini:  ArgCVEnvP;
 104                           dependencies: PROC) ;
 105 BEGIN
 106    M2Dependent.RegisterModule (name, libname, init, fini, dependencies)
 107 END RegisterModule ;
 108
 109
 110 (*
 111    RequestDependant - used to specify that modulename is dependant upon
 112                       module dependantmodule.
 113 *)
 114
 115 PROCEDURE RequestDependant (modulename, libname,
 116                             dependantmodule, dependantlibname: ADDRESS) ;
 117 BEGIN
 118    M2Dependent.RequestDependant (modulename, libname,
 119                                  dependantmodule, dependantlibname)
 120 END RequestDependant ;
 121
 122
 123 (*
 124    ExecuteReverse - execute the procedure associated with procptr
 125                     and then proceed to try and execute all previous
 126                     procedures in the chain.
 127 *)
 128
 129 PROCEDURE ExecuteReverse (procptr: ProcedureChain) ;
 130 BEGIN
 131    WHILE procptr # NIL DO
 132       procptr^.p ;  (* Invoke the procedure.  *)
 133       procptr := procptr^.prev
 134    END
 135 END ExecuteReverse ;
 136
 137
 138 (*
 139    ExecuteTerminationProcedures - calls each installed termination procedure
 140                                   in reverse order.
 141 *)
 142
 143 PROCEDURE ExecuteTerminationProcedures ;
 144 BEGIN
 145    ExecuteReverse (TerminateProc.tail)
 146 END ExecuteTerminationProcedures ;
 147
 148
 149 (*
 150    ExecuteInitialProcedures - executes the initial procedures installed by
 151                               InstallInitialProcedure.
 152 *)
 153
 154 PROCEDURE ExecuteInitialProcedures ;
 155 BEGIN
 156    ExecuteReverse (InitialProc.tail)
 157 END ExecuteInitialProcedures ;
 158
 159
 160 (*
 161    AppendProc - append proc to the end of the procedure list
 162                 defined by proclist.
 163 *)
 164
 165 PROCEDURE AppendProc (VAR proclist: ProcedureList; proc: PROC) : BOOLEAN ;
 166 VAR
 167    pdes: ProcedureChain ;
 168 BEGIN
 169    NEW (pdes) ;
 170    WITH pdes^ DO
 171       p := proc ;
 172       prev := proclist.tail ;
 173       next := NIL
 174    END ;
 175    IF proclist.head = NIL
 176    THEN
 177       proclist.head := pdes
 178    END ;
 179    proclist.tail := pdes ;
 180    RETURN TRUE
 181 END AppendProc ;
 182
 183
 184 (*
 185    InstallTerminationProcedure - installs a procedure, p, which will
 186                                  be called when the procedure
 187                                  ExecuteTerminationProcedures
 188                                  is invoked.  It returns TRUE if the
 189                                  procedure is installed.
 190 *)
 191
 192 PROCEDURE InstallTerminationProcedure (p: PROC) : BOOLEAN ;
 193 BEGIN
 194    RETURN AppendProc (TerminateProc, p)
 195 END InstallTerminationProcedure ;
 196
 197
 198 (*
 199    InstallInitialProcedure - installs a procedure to be executed just
 200                              before the BEGIN code section of the
 201                              main program module.
 202 *)
 203
 204 PROCEDURE InstallInitialProcedure (p: PROC) : BOOLEAN ;
 205 BEGIN
 206    RETURN AppendProc (InitialProc, p)
 207 END InstallInitialProcedure ;
 208
 209
 210 (*
 211    HALT - terminate the current program.  The procedure
 212           ExecuteTerminationProcedures
 213           is called before the program is stopped.  The parameter
 214           exitcode is optional.  If the parameter is not supplied
 215           HALT will call libc 'abort', otherwise it will exit with
 216           the code supplied.  Supplying a parameter to HALT has the
 217           same effect as calling ExitOnHalt with the same code and
 218           then calling HALT with no parameter.
 219 *)
 220
 221 PROCEDURE HALT ([exitcode: INTEGER = -1]) <* noreturn *> ;
 222 BEGIN
 223    IF exitcode#-1
 224    THEN
 225       CallExit := TRUE ;
 226       ExitValue := exitcode
 227    END ;
 228    IF isHalting
 229    THEN
 230       (* double HALT found *)
 231       exit(-1)
 232    ELSE
 233       isHalting := TRUE ;
 234       ExecuteTerminationProcedures ;
 235    END ;
 236    IF CallExit
 237    THEN
 238       exit(ExitValue)
 239    ELSE
 240       abort
 241    END
 242 END HALT ;
 243
 244
 245 (*
 246    Terminate - provides compatibility for pim.  It calls exit with
 247                the exitcode provided in a prior call to ExitOnHalt
 248                (or zero if ExitOnHalt was never called).  It does
 249                not call ExecuteTerminationProcedures.
 250 *)
 251
 252 PROCEDURE Terminate <* noreturn *> ;
 253 BEGIN
 254    exit (ExitValue)
 255 END Terminate ;
 256
 257
 258 (*
 259    ErrorString - writes a string to stderr.
 260 *)
 261
 262 PROCEDURE ErrorString (a: ARRAY OF CHAR) ;
 263 VAR
 264    n: INTEGER ;
 265 BEGIN
 266    n := write (stderrFd, ADR (a), StrLen (a))
 267 END ErrorString ;
 268
 269
 270 (*
 271    ErrorStringC - writes a string to stderr.
 272 *)
 273
 274 PROCEDURE ErrorStringC (str: ADDRESS) ;
 275 VAR
 276    len: INTEGER ;
 277 BEGIN
 278    len := write (stderrFd, str, strlen (str))
 279 END ErrorStringC ;
 280
 281
 282 (*
 283    ErrorMessage - emits an error message to stderr and then calls exit (1).
 284 *)
 285
 286 PROCEDURE ErrorMessage (message: ARRAY OF CHAR;
 287                         filename: ARRAY OF CHAR;
 288                         line: CARDINAL;
 289                         function: ARRAY OF CHAR) <* noreturn *> ;
 290 VAR
 291    buffer: ARRAY [0..10] OF CHAR ;
 292 BEGIN
 293    ErrorString (filename) ; ErrorString(':') ;
 294    CardToStr (line, 0, buffer) ;
 295    ErrorString (buffer) ; ErrorString(':') ;
 296    IF NOT StrEqual (function, '')
 297    THEN
 298       ErrorString ('in ') ;
 299       ErrorString (function) ;
 300       ErrorString (' has caused ') ;
 301    END ;
 302    ErrorString (message) ;
 303    buffer[0] := nl ; buffer[1] := nul ;
 304    ErrorString (buffer) ;
 305    exit (1)
 306 END ErrorMessage ;
 307
 308
 309 (*
 310    ErrorMessageC - emits an error message to stderr and then calls exit (1).
 311 *)
 312
 313 PROCEDURE ErrorMessageC (message, filename: ADDRESS;
 314                          line: CARDINAL;
 315                          function: ADDRESS) <* noreturn *> ;
 316 VAR
 317    buffer: ARRAY [0..10] OF CHAR ;
 318 BEGIN
 319    ErrorStringC (filename) ; ErrorString (':') ;
 320    CardToStr (line, 0, buffer) ;
 321    ErrorString (buffer) ; ErrorString(':') ;
 322    IF strlen (function) > 0
 323    THEN
 324       ErrorString ('in ') ;
 325       ErrorStringC (function) ;
 326       ErrorString (' has caused ') ;
 327    END ;
 328    ErrorStringC (message) ;
 329    buffer[0] := nl ; buffer[1] := nul ;
 330    ErrorString (buffer) ;
 331    exit (1)
 332 END ErrorMessageC ;
 333
 334
 335 (*
 336    HaltC - provides a more user friendly version of HALT, which takes
 337            four parameters to aid debugging.  It writes an error message
 338            to stderr and calls exit (1).
 339 *)
 340
 341 PROCEDURE HaltC (description, filename, function: ADDRESS; line: CARDINAL) ;
 342 BEGIN
 343    ErrorMessageC (description, filename, line, function)
 344 END HaltC ;
 345
 346
 347 (*
 348    Halt - provides a more user friendly version of HALT, which takes
 349           four parameters to aid debugging.  It writes an error message
 350           to stderr and calls exit (1).
 351 *)
 352
 353 PROCEDURE Halt (description, filename, function: ARRAY OF CHAR; line: CARDINAL) ;
 354 BEGIN
 355    ErrorMessage (description, filename, line, function)
 356 END Halt ;
 357
 358
 359 (*
 360    The following are the runtime exception handler routines.
 361 *)
 362
 363 PROCEDURE AssignmentException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 364 BEGIN
 365    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 366                        filename, line, column, scope, message)
 367 END AssignmentException ;
 368
 369
 370 PROCEDURE ReturnException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 371 BEGIN
 372    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 373                        filename, line, column, scope, message)
 374 END ReturnException ;
 375
 376
 377 PROCEDURE IncException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 378 BEGIN
 379    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 380                        filename, line, column, scope, message)
 381 END IncException ;
 382
 383
 384 PROCEDURE DecException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 385 BEGIN
 386    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 387                        filename, line, column, scope, message)
 388 END DecException ;
 389
 390
 391 PROCEDURE InclException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 392 BEGIN
 393    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 394                        filename, line, column, scope, message)
 395 END InclException ;
 396
 397
 398 PROCEDURE ExclException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 399 BEGIN
 400    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 401                       filename, line, column, scope, message)
 402 END ExclException ;
 403
 404
 405 PROCEDURE ShiftException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 406 BEGIN
 407    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 408                        filename, line, column, scope, message)
 409 END ShiftException ;
 410
 411
 412 PROCEDURE RotateException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 413 BEGIN
 414    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 415                        filename, line, column, scope, message)
 416 END RotateException ;
 417
 418
 419 PROCEDURE StaticArraySubscriptException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 420 BEGIN
 421    RTExceptions.Raise (ORD (M2EXCEPTION.indexException),
 422                        filename, line, column, scope, message)
 423 END StaticArraySubscriptException ;
 424
 425
 426 PROCEDURE DynamicArraySubscriptException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 427 BEGIN
 428    RTExceptions.Raise (ORD (M2EXCEPTION.indexException),
 429                        filename, line, column, scope, message)
 430 END DynamicArraySubscriptException ;
 431
 432
 433 PROCEDURE ForLoopBeginException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 434 BEGIN
 435    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 436                        filename, line, column, scope, message)
 437 END ForLoopBeginException ;
 438
 439
 440 PROCEDURE ForLoopToException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 441 BEGIN
 442    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 443                        filename, line, column, scope, message)
 444 END ForLoopToException ;
 445
 446
 447 PROCEDURE ForLoopEndException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 448 BEGIN
 449    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 450                        filename, line, column, scope, message)
 451 END ForLoopEndException ;
 452
 453
 454 PROCEDURE PointerNilException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 455 BEGIN
 456    RTExceptions.Raise (ORD (M2EXCEPTION.invalidLocation),
 457                        filename, line, column, scope, message)
 458 END PointerNilException ;
 459
 460
 461 PROCEDURE NoReturnException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 462 BEGIN
 463    RTExceptions.Raise (ORD (M2EXCEPTION.functionException),
 464                        filename, line, column, scope, message)
 465 END NoReturnException ;
 466
 467
 468 PROCEDURE CaseException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 469 BEGIN
 470    RTExceptions.Raise (ORD (M2EXCEPTION.caseSelectException),
 471                        filename, line, column, scope, message)
 472 END CaseException ;
 473
 474
 475 PROCEDURE WholeNonPosDivException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 476 BEGIN
 477    RTExceptions.Raise (ORD (M2EXCEPTION.wholeDivException),
 478                        filename, line, column, scope, message)
 479 END WholeNonPosDivException ;
 480
 481
 482 PROCEDURE WholeNonPosModException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 483 BEGIN
 484    RTExceptions.Raise (ORD (M2EXCEPTION.wholeDivException),
 485                        filename, line, column, scope, message)
 486 END WholeNonPosModException ;
 487
 488
 489 PROCEDURE WholeZeroDivException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 490 BEGIN
 491    RTExceptions.Raise(ORD (M2EXCEPTION.wholeDivException),
 492                       filename, line, column, scope, message)
 493 END WholeZeroDivException ;
 494
 495
 496 PROCEDURE WholeZeroRemException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 497 BEGIN
 498    RTExceptions.Raise (ORD (M2EXCEPTION.wholeDivException),
 499                        filename, line, column, scope, message)
 500 END WholeZeroRemException ;
 501
 502
 503 PROCEDURE WholeValueException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 504 BEGIN
 505    RTExceptions.Raise (ORD (M2EXCEPTION.wholeValueException),
 506                        filename, line, column, scope, message)
 507 END WholeValueException ;
 508
 509
 510 PROCEDURE RealValueException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 511 BEGIN
 512    RTExceptions.Raise (ORD (M2EXCEPTION.realValueException),
 513                        filename, line, column, scope, message)
 514 END RealValueException ;
 515
 516
 517 PROCEDURE ParameterException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 518 BEGIN
 519    RTExceptions.Raise (ORD (M2EXCEPTION.rangeException),
 520                        filename, line, column, scope, message)
 521 END ParameterException ;
 522
 523
 524 PROCEDURE NoException (filename: ADDRESS; line, column: CARDINAL; scope, message: ADDRESS) ;
 525 BEGIN
 526    RTExceptions.Raise (ORD (M2EXCEPTION.exException),
 527                        filename, line, column, scope, message)
 528 END NoException ;
 529
 530
 531 (*
 532    ExitOnHalt - if HALT is executed then call exit with the exit code, e.
 533 *)
 534
 535 PROCEDURE ExitOnHalt (e: INTEGER) ;
 536 BEGIN
 537    ExitValue := e ;
 538    CallExit := TRUE
 539 END ExitOnHalt ;
 540
 541
 542 (*
 543    Length - returns the length of a string, a. This is called whenever
 544             the user calls LENGTH and the parameter cannot be calculated
 545             at compile time.
 546 *)
 547
 548 PROCEDURE Length (a: ARRAY OF CHAR) : CARDINAL ;
 549 VAR
 550    l, h: CARDINAL ;
 551 BEGIN
 552    l := 0 ;
 553    h := HIGH(a) ;
 554    WHILE (l<=h) AND (a[l]#nul) DO
 555       INC(l)
 556    END ;
 557    RETURN( l )
 558 END Length ;
 559
 560
 561 (*
 562    InitProcList - initialize the head and tail pointers to NIL.
 563 *)
 564
 565 PROCEDURE InitProcList (VAR p: ProcedureList) ;
 566 BEGIN
 567    p.head := NIL ;
 568    p.tail := NIL
 569 END InitProcList ;
 570
 571
 572 (*
 573    Init - initialize the initial, terminate procedure lists and booleans.
 574 *)
 575
 576 PROCEDURE Init ;
 577 BEGIN
 578    InitProcList (InitialProc) ;
 579    InitProcList (TerminateProc) ;
 580    ExitValue := 0 ;
 581    isHalting := FALSE ;
 582    CallExit := FALSE   (* default by calling abort *)
 583 END Init ;
 584
 585
 586 (*
 587    CheckInitialized - checks to see if this module has been initialized
 588                       and if it has not it calls Init.  We need this
 589                       approach as this module is called by module ctors
 590                       before we reach main.
 591 *)
 592
 593 PROCEDURE CheckInitialized ;
 594 BEGIN
 595    IF NOT Initialized
 596    THEN
 597       Initialized := TRUE ;
 598       Init
 599    END
 600 END CheckInitialized ;
 601
 602
 603 BEGIN
 604    CheckInitialized
 605 END M2RTS.