gcc/m2/gm2-libs-iso/M2RTS.mod

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