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