]>
Commit | Line | Data |
---|---|---|
7401123f GM |
1 | (* PCSymBuild.mod pass C symbol creation. |
2 | ||
3 | Copyright (C) 2001-2021 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 | You should have received a copy of the GNU General Public License | |
19 | along with GNU Modula-2; see the file COPYING3. If not see | |
20 | <http://www.gnu.org/licenses/>. *) | |
21 | ||
22 | IMPLEMENTATION MODULE PCSymBuild ; | |
23 | ||
24 | ||
25 | FROM Storage IMPORT ALLOCATE, DEALLOCATE ; | |
26 | FROM NameKey IMPORT Name, WriteKey, MakeKey, NulName ; | |
27 | FROM StrIO IMPORT WriteString, WriteLn ; | |
28 | FROM NumberIO IMPORT WriteCard ; | |
29 | FROM M2Debug IMPORT Assert, WriteDebug ; | |
30 | FROM M2Error IMPORT WriteFormat0, WriteFormat1, WriteFormat2, FlushErrors, InternalError, NewError, ErrorFormat0 ; | |
31 | FROM M2MetaError IMPORT MetaError1 ; | |
32 | FROM M2LexBuf IMPORT GetTokenNo ; | |
33 | FROM M2Reserved IMPORT NulTok, ImportTok ; | |
34 | FROM M2Const IMPORT constType ; | |
35 | FROM Indexing IMPORT Index, InitIndex, GetIndice, PutIndice, InBounds, IncludeIndiceIntoIndex, HighIndice ; | |
36 | ||
37 | FROM M2Quads IMPORT PushT, PopT, OperandT, PopN, PopTF, PushTF, IsAutoPushOn, | |
38 | PopNothing, PushTFn, PopTFn, PushTtok, PopTtok, PushTFtok, PopTFtok, OperandTok ; | |
39 | ||
40 | FROM M2Options IMPORT Iso ; | |
41 | FROM StdIO IMPORT Write ; | |
42 | FROM M2System IMPORT IsPseudoSystemFunctionConstExpression ; | |
43 | ||
44 | FROM M2Base IMPORT MixTypes, | |
45 | ZType, RType, Char, Boolean, Val, Max, Min, Convert, | |
46 | IsPseudoBaseFunction, IsRealType, IsComplexType, IsOrdinalType ; | |
47 | ||
48 | FROM M2Reserved IMPORT PlusTok, MinusTok, TimesTok, DivTok, ModTok, | |
49 | DivideTok, RemTok, | |
50 | OrTok, AndTok, AmbersandTok, | |
51 | EqualTok, LessEqualTok, GreaterEqualTok, | |
52 | LessTok, GreaterTok, HashTok, LessGreaterTok, | |
53 | InTok, NotTok ; | |
54 | ||
55 | FROM SymbolTable IMPORT NulSym, ModeOfAddr, | |
56 | StartScope, EndScope, GetScope, GetCurrentScope, | |
57 | GetModuleScope, | |
58 | SetCurrentModule, GetCurrentModule, SetFileModule, | |
59 | GetExported, | |
60 | IsDefImp, IsModule, | |
61 | RequestSym, | |
62 | IsProcedure, PutOptArgInit, IsEnumeration, | |
63 | CheckForUnknownInModule, | |
64 | GetFromOuterModule, | |
65 | CheckForEnumerationInCurrentModule, | |
66 | GetMode, PutVariableAtAddress, ModeOfAddr, SkipType, | |
67 | IsSet, PutConstSet, | |
68 | IsConst, IsConstructor, PutConst, PutConstructor, | |
69 | PopValue, PushValue, | |
70 | MakeTemporary, PutVar, | |
71 | PutSubrange, | |
72 | GetSymName, | |
73 | CheckAnonymous, | |
74 | IsProcedureBuiltin, | |
75 | MakeProcType, | |
76 | NoOfParam, | |
77 | GetParam, | |
78 | IsParameterVar, PutProcTypeParam, | |
79 | PutProcTypeVarParam, IsParameterUnbounded, | |
80 | PutFunction, PutProcTypeParam, | |
81 | GetType, | |
82 | IsAModula2Type, GetDeclaredMod ; | |
83 | ||
84 | FROM M2Batch IMPORT MakeDefinitionSource, | |
85 | MakeImplementationSource, | |
86 | MakeProgramSource, | |
87 | LookupModule, LookupOuterModule ; | |
88 | ||
89 | FROM M2Comp IMPORT CompilingDefinitionModule, | |
90 | CompilingImplementationModule, | |
91 | CompilingProgramModule ; | |
92 | ||
93 | FROM M2StackAddress IMPORT StackOfAddress, InitStackAddress, KillStackAddress, | |
94 | PushAddress, PopAddress, PeepAddress, | |
95 | IsEmptyAddress, NoOfItemsInStackAddress ; | |
96 | ||
97 | FROM M2StackWord IMPORT StackOfWord, InitStackWord, KillStackWord, | |
98 | PushWord, PopWord, PeepWord, | |
99 | IsEmptyWord, NoOfItemsInStackWord ; | |
100 | ||
e61ec3e2 GM |
101 | IMPORT M2Error ; |
102 | ||
7401123f GM |
103 | |
104 | CONST | |
105 | Debugging = FALSE ; | |
106 | ||
107 | TYPE | |
108 | tagType = (leaf, unary, binary, designator, expr, convert, function) ; | |
109 | ||
110 | exprNode = POINTER TO eNode ; | |
111 | ||
112 | eDes = RECORD | |
113 | type: CARDINAL ; | |
114 | meta: constType ; | |
115 | sym : CARDINAL ; | |
116 | left: exprNode ; | |
117 | END ; | |
118 | ||
119 | eLeaf = RECORD | |
120 | type: CARDINAL ; | |
121 | meta: constType ; | |
122 | sym: CARDINAL ; | |
123 | END ; | |
124 | ||
125 | eUnary = RECORD | |
126 | type: CARDINAL ; | |
127 | meta: constType ; | |
128 | left: exprNode ; | |
129 | op : Name ; | |
130 | END ; | |
131 | ||
132 | eBinary = RECORD | |
133 | type: CARDINAL ; | |
134 | meta: constType ; | |
135 | left, | |
136 | right: exprNode ; | |
137 | op : Name ; | |
138 | END ; | |
139 | ||
140 | eExpr = RECORD | |
141 | type: CARDINAL ; | |
142 | meta: constType ; | |
143 | left: exprNode ; | |
144 | END ; | |
145 | ||
146 | eFunction = RECORD | |
147 | type : CARDINAL ; | |
148 | meta : constType ; | |
149 | func : CARDINAL ; | |
150 | first, | |
151 | second: exprNode ; | |
152 | third : BOOLEAN ; | |
153 | END ; | |
154 | ||
155 | eConvert = RECORD | |
156 | type : CARDINAL ; | |
157 | meta : constType ; | |
158 | totype: exprNode ; | |
159 | expr : exprNode ; | |
160 | END ; | |
161 | ||
162 | eNode = RECORD | |
163 | CASE tag: tagType OF | |
164 | ||
165 | designator: edes : eDes | | |
166 | leaf : eleaf : eLeaf | | |
167 | unary : eunary : eUnary | | |
168 | binary : ebinary : eBinary | | |
169 | expr : eexpr : eExpr | | |
170 | function : efunction: eFunction | | |
171 | convert : econvert : eConvert | |
172 | ||
173 | END | |
174 | END ; | |
175 | ||
176 | ||
177 | VAR | |
7401123f GM |
178 | exprStack : StackOfAddress ; |
179 | constList : Index ; | |
180 | constToken : CARDINAL ; | |
7401123f GM |
181 | desStack : StackOfWord ; |
182 | inDesignator: BOOLEAN ; | |
183 | ||
184 | ||
185 | (* | |
186 | GetSkippedType - | |
187 | *) | |
188 | ||
189 | PROCEDURE GetSkippedType (sym: CARDINAL) : CARDINAL ; | |
190 | BEGIN | |
191 | RETURN( SkipType(GetType(sym)) ) | |
192 | END GetSkippedType ; | |
193 | ||
194 | ||
195 | (* | |
196 | StartBuildDefinitionModule - Creates a definition module and starts | |
197 | a new scope. | |
198 | ||
199 | The Stack is expected: | |
200 | ||
201 | Entry Exit | |
202 | ||
203 | Ptr -> <- Ptr | |
204 | +------------+ +-----------+ | |
205 | | NameStart | | NameStart | | |
206 | |------------| |-----------| | |
207 | ||
208 | *) | |
209 | ||
210 | PROCEDURE PCStartBuildDefModule ; | |
211 | VAR | |
212 | tok : CARDINAL ; | |
213 | name : Name ; | |
214 | ModuleSym: CARDINAL ; | |
215 | BEGIN | |
216 | PopTtok(name, tok) ; | |
217 | ModuleSym := MakeDefinitionSource(tok, name) ; | |
218 | SetCurrentModule(ModuleSym) ; | |
219 | SetFileModule(ModuleSym) ; | |
220 | StartScope(ModuleSym) ; | |
221 | Assert(IsDefImp(ModuleSym)) ; | |
222 | Assert(CompilingDefinitionModule()) ; | |
e61ec3e2 GM |
223 | PushT(name) ; |
224 | M2Error.EnterDefinitionScope (name) | |
7401123f GM |
225 | END PCStartBuildDefModule ; |
226 | ||
227 | ||
228 | (* | |
229 | EndBuildDefinitionModule - Destroys the definition module scope and | |
230 | checks for correct name. | |
231 | ||
232 | The Stack is expected: | |
233 | ||
234 | Entry Exit | |
235 | ||
236 | Ptr -> | |
237 | +------------+ +-----------+ | |
238 | | NameEnd | | | | |
239 | |------------| |-----------| | |
240 | | NameStart | | | <- Ptr | |
241 | |------------| |-----------| | |
242 | *) | |
243 | ||
244 | PROCEDURE PCEndBuildDefModule ; | |
245 | VAR | |
246 | NameStart, | |
247 | NameEnd : CARDINAL ; | |
248 | BEGIN | |
249 | Assert(CompilingDefinitionModule()) ; | |
250 | CheckForUnknownInModule ; | |
251 | EndScope ; | |
252 | PopT(NameEnd) ; | |
253 | PopT(NameStart) ; | |
254 | IF NameStart#NameEnd | |
255 | THEN | |
256 | WriteFormat2('inconsistant definition module was named (%a) and concluded as (%a)', | |
257 | NameStart, NameEnd) | |
e61ec3e2 | 258 | END ; |
966f05c8 | 259 | M2Error.LeaveErrorScope |
7401123f GM |
260 | END PCEndBuildDefModule ; |
261 | ||
262 | ||
263 | (* | |
264 | StartBuildImplementationModule - Creates an implementation module and starts | |
265 | a new scope. | |
266 | ||
267 | The Stack is expected: | |
268 | ||
269 | Entry Exit | |
270 | ||
271 | Ptr -> <- Ptr | |
272 | +------------+ +-----------+ | |
273 | | NameStart | | NameStart | | |
274 | |------------| |-----------| | |
275 | ||
276 | *) | |
277 | ||
278 | PROCEDURE PCStartBuildImpModule ; | |
279 | VAR | |
280 | tok : CARDINAL ; | |
281 | name : Name ; | |
282 | ModuleSym: CARDINAL ; | |
283 | BEGIN | |
284 | PopTtok(name, tok) ; | |
285 | ModuleSym := MakeImplementationSource(tok, name) ; | |
286 | SetCurrentModule(ModuleSym) ; | |
287 | SetFileModule(ModuleSym) ; | |
288 | StartScope(ModuleSym) ; | |
289 | Assert(IsDefImp(ModuleSym)) ; | |
290 | Assert(CompilingImplementationModule()) ; | |
e61ec3e2 GM |
291 | PushTtok(name, tok) ; |
292 | M2Error.EnterImplementationScope (name) | |
7401123f GM |
293 | END PCStartBuildImpModule ; |
294 | ||
295 | ||
296 | (* | |
297 | EndBuildImplementationModule - Destroys the implementation module scope and | |
298 | checks for correct name. | |
299 | ||
300 | The Stack is expected: | |
301 | ||
302 | Entry Exit | |
303 | ||
304 | Ptr -> | |
305 | +------------+ +-----------+ | |
306 | | NameEnd | | | | |
307 | |------------| |-----------| | |
308 | | NameStart | | | <- Ptr | |
309 | |------------| |-----------| | |
310 | *) | |
311 | ||
312 | PROCEDURE PCEndBuildImpModule ; | |
313 | VAR | |
314 | NameStart, | |
315 | NameEnd : Name ; | |
316 | BEGIN | |
317 | Assert(CompilingImplementationModule()) ; | |
318 | CheckForUnknownInModule ; | |
319 | EndScope ; | |
320 | PopT(NameEnd) ; | |
321 | PopT(NameStart) ; | |
322 | IF NameStart#NameEnd | |
323 | THEN | |
324 | (* we dont issue an error based around incorrect module names as this is done in P1 and P2. | |
325 | If we get here then something has gone wrong with our error recovery in PC, so we bail out. | |
326 | *) | |
327 | WriteFormat0('too many errors in pass 3') ; | |
328 | FlushErrors | |
e61ec3e2 | 329 | END ; |
966f05c8 | 330 | M2Error.LeaveErrorScope |
7401123f GM |
331 | END PCEndBuildImpModule ; |
332 | ||
333 | ||
334 | (* | |
335 | StartBuildProgramModule - Creates a program module and starts | |
336 | a new scope. | |
337 | ||
338 | The Stack is expected: | |
339 | ||
340 | Entry Exit | |
341 | ||
342 | Ptr -> <- Ptr | |
343 | +------------+ +-----------+ | |
344 | | NameStart | | NameStart | | |
345 | |------------| |-----------| | |
346 | ||
347 | *) | |
348 | ||
349 | PROCEDURE PCStartBuildProgModule ; | |
350 | VAR | |
351 | tok : CARDINAL ; | |
352 | name : Name ; | |
353 | ModuleSym: CARDINAL ; | |
354 | BEGIN | |
355 | (* WriteString('StartBuildProgramModule') ; WriteLn ; *) | |
356 | PopTtok(name, tok) ; | |
357 | ModuleSym := MakeProgramSource(tok, name) ; | |
358 | SetCurrentModule(ModuleSym) ; | |
359 | SetFileModule(ModuleSym) ; | |
360 | (* WriteString('MODULE - ') ; WriteKey(GetSymName(ModuleSym)) ; WriteLn ; *) | |
361 | StartScope(ModuleSym) ; | |
362 | Assert(CompilingProgramModule()) ; | |
363 | Assert(NOT IsDefImp(ModuleSym)) ; | |
e61ec3e2 GM |
364 | PushTtok(name, tok) ; |
365 | M2Error.EnterProgramScope (name) | |
7401123f GM |
366 | END PCStartBuildProgModule ; |
367 | ||
368 | ||
369 | (* | |
370 | EndBuildProgramModule - Destroys the program module scope and | |
371 | checks for correct name. | |
372 | ||
373 | The Stack is expected: | |
374 | ||
375 | Entry Exit | |
376 | ||
377 | Ptr -> | |
378 | +------------+ +-----------+ | |
379 | | NameEnd | | | | |
380 | |------------| |-----------| | |
381 | | NameStart | | | <- Ptr | |
382 | |------------| |-----------| | |
383 | *) | |
384 | ||
385 | PROCEDURE PCEndBuildProgModule ; | |
386 | VAR | |
387 | NameStart, | |
388 | NameEnd : Name ; | |
389 | BEGIN | |
390 | Assert(CompilingProgramModule()) ; | |
391 | CheckForUnknownInModule ; | |
392 | EndScope ; | |
393 | PopT(NameEnd) ; | |
394 | PopT(NameStart) ; | |
395 | IF NameStart#NameEnd | |
396 | THEN | |
397 | (* we dont issue an error based around incorrect module names this would be done in P1 and P2. | |
398 | If we get here then something has gone wrong with our error recovery in PC, so we bail out. | |
399 | *) | |
400 | WriteFormat0('too many errors in pass 3') ; | |
401 | FlushErrors | |
e61ec3e2 | 402 | END ; |
966f05c8 | 403 | M2Error.LeaveErrorScope |
7401123f GM |
404 | END PCEndBuildProgModule ; |
405 | ||
406 | ||
407 | (* | |
408 | StartBuildInnerModule - Creates an Inner module and starts | |
409 | a new scope. | |
410 | ||
411 | The Stack is expected: | |
412 | ||
413 | Entry Exit | |
414 | ||
415 | Ptr -> <- Ptr | |
416 | +------------+ +-----------+ | |
417 | | NameStart | | NameStart | | |
418 | |------------| |-----------| | |
419 | ||
420 | *) | |
421 | ||
422 | PROCEDURE PCStartBuildInnerModule ; | |
423 | VAR | |
424 | name : Name ; | |
425 | tok : CARDINAL ; | |
426 | ModuleSym: CARDINAL ; | |
427 | BEGIN | |
428 | PopTtok(name, tok) ; | |
429 | ModuleSym := RequestSym(tok, name) ; | |
430 | Assert(IsModule(ModuleSym)) ; | |
431 | StartScope(ModuleSym) ; | |
432 | Assert(NOT IsDefImp(ModuleSym)) ; | |
433 | SetCurrentModule(ModuleSym) ; | |
e61ec3e2 GM |
434 | PushTtok(name, tok) ; |
435 | M2Error.EnterModuleScope (name) | |
7401123f GM |
436 | END PCStartBuildInnerModule ; |
437 | ||
438 | ||
439 | (* | |
440 | EndBuildInnerModule - Destroys the Inner module scope and | |
441 | checks for correct name. | |
442 | ||
443 | The Stack is expected: | |
444 | ||
445 | Entry Exit | |
446 | ||
447 | Ptr -> | |
448 | +------------+ +-----------+ | |
449 | | NameEnd | | | | |
450 | |------------| |-----------| | |
451 | | NameStart | | | <- Ptr | |
452 | |------------| |-----------| | |
453 | *) | |
454 | ||
455 | PROCEDURE PCEndBuildInnerModule ; | |
456 | VAR | |
457 | NameStart, | |
458 | NameEnd : Name ; | |
459 | BEGIN | |
460 | CheckForUnknownInModule ; | |
461 | EndScope ; | |
462 | PopT(NameEnd) ; | |
463 | PopT(NameStart) ; | |
464 | IF NameStart#NameEnd | |
465 | THEN | |
466 | (* we dont issue an error based around incorrect module names this would be done in P1 and P2. | |
467 | If we get here then something has gone wrong with our error recovery in PC, so we bail out. | |
468 | *) | |
469 | WriteFormat0('too many errors in pass 3') ; | |
470 | FlushErrors | |
471 | END ; | |
e61ec3e2 | 472 | SetCurrentModule(GetModuleScope(GetCurrentModule())) ; |
966f05c8 | 473 | M2Error.LeaveErrorScope |
7401123f GM |
474 | END PCEndBuildInnerModule ; |
475 | ||
476 | ||
477 | (* | |
478 | BuildImportOuterModule - Builds imported identifiers into an outer module | |
479 | from a definition module. | |
480 | ||
481 | The Stack is expected: | |
482 | ||
483 | Entry OR Entry | |
484 | ||
485 | Ptr -> Ptr -> | |
486 | +------------+ +-----------+ | |
487 | | # | | # | | |
488 | |------------| |-----------| | |
489 | | Id1 | | Id1 | | |
490 | |------------| |-----------| | |
491 | . . . . | |
492 | . . . . | |
493 | . . . . | |
494 | |------------| |-----------| | |
495 | | Id# | | Id# | | |
496 | |------------| |-----------| | |
497 | | ImportTok | | Ident | | |
498 | |------------| |-----------| | |
499 | ||
500 | IMPORT Id1, .. Id# ; FROM Ident IMPORT Id1 .. Id# ; | |
501 | ||
502 | ||
503 | Exit | |
504 | ||
505 | All above stack discarded | |
506 | *) | |
507 | ||
508 | PROCEDURE PCBuildImportOuterModule ; | |
509 | VAR | |
510 | Sym, ModSym, | |
511 | i, n : CARDINAL ; | |
512 | BEGIN | |
513 | PopT(n) ; (* n = # of the Ident List *) | |
514 | IF OperandT(n+1)#ImportTok | |
515 | THEN | |
516 | (* Ident List contains list of objects imported from ModSym *) | |
517 | ModSym := LookupModule(OperandTok(n+1), OperandT(n+1)) ; | |
518 | i := 1 ; | |
519 | WHILE i<=n DO | |
520 | Sym := GetExported (OperandTok (i), ModSym, OperandT (i)) ; | |
521 | CheckForEnumerationInCurrentModule(Sym) ; | |
522 | INC(i) | |
523 | END | |
524 | END ; | |
525 | PopN(n+1) (* clear stack *) | |
526 | END PCBuildImportOuterModule ; | |
527 | ||
528 | ||
529 | (* | |
530 | BuildImportInnerModule - Builds imported identifiers into an inner module | |
531 | from the last level of module. | |
532 | ||
533 | The Stack is expected: | |
534 | ||
535 | Entry OR Entry | |
536 | ||
537 | Ptr -> Ptr -> | |
538 | +------------+ +-----------+ | |
539 | | # | | # | | |
540 | |------------| |-----------| | |
541 | | Id1 | | Id1 | | |
542 | |------------| |-----------| | |
543 | . . . . | |
544 | . . . . | |
545 | . . . . | |
546 | |------------| |-----------| | |
547 | | Id# | | Id# | | |
548 | |------------| |-----------| | |
549 | | ImportTok | | Ident | | |
550 | |------------| |-----------| | |
551 | ||
552 | IMPORT Id1, .. Id# ; FROM Ident IMPORT Id1 .. Id# ; | |
553 | ||
554 | Exit | |
555 | ||
556 | All above stack discarded | |
557 | *) | |
558 | ||
559 | PROCEDURE PCBuildImportInnerModule ; | |
560 | VAR | |
561 | Sym, ModSym, | |
562 | n, i : CARDINAL ; | |
563 | BEGIN | |
564 | PopT (n) ; (* i = # of the Ident List *) | |
565 | IF OperandT (n+1) = ImportTok | |
566 | THEN | |
567 | (* Ident List contains list of objects *) | |
568 | i := 1 ; | |
569 | WHILE i<=n DO | |
570 | Sym := GetFromOuterModule (OperandTok (i), OperandT (i)) ; | |
571 | CheckForEnumerationInCurrentModule(Sym) ; | |
572 | INC(i) | |
573 | END | |
574 | ELSE | |
575 | (* Ident List contains list of objects imported from ModSym *) | |
576 | ModSym := LookupOuterModule (OperandTok (n+1), OperandT (n+1)) ; | |
577 | i := 1 ; | |
578 | WHILE i<=n DO | |
579 | Sym := GetExported (OperandTok (i), ModSym, OperandT (i)) ; | |
580 | CheckForEnumerationInCurrentModule (Sym) ; | |
581 | INC (i) | |
582 | END | |
583 | END ; | |
584 | PopN (n+1) (* Clear Stack *) | |
585 | END PCBuildImportInnerModule ; | |
586 | ||
587 | ||
588 | PROCEDURE stop ; BEGIN END stop ; | |
589 | ||
590 | ||
591 | (* | |
592 | StartBuildProcedure - Builds a Procedure. | |
593 | ||
594 | The Stack: | |
595 | ||
596 | Entry Exit | |
597 | ||
598 | <- Ptr | |
599 | +------------+ | |
600 | Ptr -> | ProcSym | | |
601 | +------------+ |------------| | |
602 | | Name | | Name | | |
603 | |------------| |------------| | |
604 | *) | |
605 | ||
606 | PROCEDURE PCStartBuildProcedure ; | |
607 | VAR | |
608 | name : Name ; | |
609 | ProcSym : CARDINAL ; | |
610 | tok : CARDINAL ; | |
611 | BEGIN | |
612 | PopTtok(name, tok) ; | |
613 | PushTtok(name, tok) ; (* Name saved for the EndBuildProcedure name check *) | |
614 | IF name=1181 | |
615 | THEN | |
616 | stop | |
617 | END ; | |
618 | ProcSym := RequestSym (tok, name) ; | |
619 | Assert (IsProcedure (ProcSym)) ; | |
620 | PushTtok (ProcSym, tok) ; | |
e61ec3e2 GM |
621 | StartScope (ProcSym) ; |
622 | M2Error.EnterProcedureScope (name) | |
7401123f GM |
623 | END PCStartBuildProcedure ; |
624 | ||
625 | ||
626 | (* | |
627 | EndBuildProcedure - Ends building a Procedure. | |
628 | It checks the start procedure name matches the end | |
629 | procedure name. | |
630 | ||
631 | The Stack: | |
632 | ||
633 | (Procedure Not Defined in definition module) | |
634 | ||
635 | Entry Exit | |
636 | ||
637 | Ptr -> | |
638 | +------------+ | |
639 | | NameEnd | | |
640 | |------------| | |
641 | | ProcSym | | |
642 | |------------| | |
643 | | NameStart | | |
644 | |------------| | |
645 | Empty | |
646 | *) | |
647 | ||
648 | PROCEDURE PCEndBuildProcedure ; | |
649 | VAR | |
650 | ProcSym : CARDINAL ; | |
651 | NameEnd, | |
652 | NameStart: Name ; | |
653 | BEGIN | |
654 | PopT(NameEnd) ; | |
655 | PopT(ProcSym) ; | |
656 | PopT(NameStart) ; | |
657 | IF NameEnd#NameStart | |
658 | THEN | |
659 | (* we dont issue an error based around incorrect module names this would be done in P1 and P2. | |
660 | If we get here then something has gone wrong with our error recovery in PC, so we bail out. | |
661 | *) | |
662 | WriteFormat0('too many errors in pass 3') ; | |
663 | FlushErrors | |
664 | END ; | |
e61ec3e2 | 665 | EndScope ; |
966f05c8 | 666 | M2Error.LeaveErrorScope |
7401123f GM |
667 | END PCEndBuildProcedure ; |
668 | ||
669 | ||
670 | (* | |
671 | BuildProcedureHeading - Builds a procedure heading for the definition | |
672 | module procedures. | |
673 | ||
674 | Operation only performed if compiling a | |
675 | definition module. | |
676 | ||
677 | The Stack: | |
678 | ||
679 | Entry Exit | |
680 | ||
681 | Ptr -> | |
682 | +------------+ | |
683 | | ProcSym | | |
684 | |------------| | |
685 | | NameStart | | |
686 | |------------| | |
687 | Empty | |
688 | ||
689 | *) | |
690 | ||
691 | PROCEDURE PCBuildProcedureHeading ; | |
692 | VAR | |
693 | ProcSym : CARDINAL ; | |
694 | NameStart: Name ; | |
695 | BEGIN | |
696 | IF CompilingDefinitionModule() | |
697 | THEN | |
698 | PopT(ProcSym) ; | |
699 | PopT(NameStart) ; | |
700 | EndScope | |
701 | END | |
702 | END PCBuildProcedureHeading ; | |
703 | ||
704 | ||
705 | (* | |
706 | BuildNulName - Pushes a NulKey onto the top of the stack. | |
707 | The Stack: | |
708 | ||
709 | ||
710 | Entry Exit | |
711 | ||
712 | <- Ptr | |
713 | Empty +------------+ | |
714 | | NulKey | | |
715 | |------------| | |
716 | *) | |
717 | ||
718 | PROCEDURE BuildNulName ; | |
719 | BEGIN | |
720 | PushT(NulName) | |
721 | END BuildNulName ; | |
722 | ||
723 | ||
724 | (* | |
725 | BuildConst - builds a constant. | |
726 | Stack | |
727 | ||
728 | Entry Exit | |
729 | ||
730 | Ptr -> <- Ptr | |
731 | +------------+ +------------+ | |
732 | | Name | | Sym | | |
733 | |------------+ |------------| | |
734 | *) | |
735 | ||
736 | PROCEDURE BuildConst ; | |
737 | VAR | |
738 | name: Name ; | |
739 | tok : CARDINAL ; | |
740 | Sym : CARDINAL ; | |
741 | BEGIN | |
742 | PopTtok (name, tok) ; | |
743 | Sym := RequestSym (tok, name) ; | |
744 | PushTtok (Sym, tok) | |
745 | END BuildConst ; | |
746 | ||
747 | ||
748 | (* | |
749 | BuildVarAtAddress - updates the symbol table entry of, variable sym, to be declared | |
750 | at address, address. | |
751 | ||
752 | Stack | |
753 | ||
754 | Entry Exit | |
755 | ||
756 | Ptr -> | |
757 | +--------------+ | |
758 | | Expr | EType | <- Ptr | |
759 | |--------------+ +--------------+ | |
760 | | name | SType | | name | SType | | |
761 | |--------------+ |--------------| | |
762 | *) | |
763 | ||
c9fba1bc | 764 | (* |
7401123f GM |
765 | PROCEDURE BuildVarAtAddress ; |
766 | VAR | |
767 | name : Name ; | |
768 | Sym, SType, | |
769 | Exp, EType: CARDINAL ; | |
770 | etok, ntok: CARDINAL ; | |
771 | BEGIN | |
772 | PopTFtok (Exp, EType, etok) ; | |
773 | PopTFtok (name, SType, ntok) ; | |
774 | PushTFtok (name, SType, ntok) ; | |
775 | Sym := RequestSym (ntok, name) ; | |
776 | IF GetMode(Sym)=LeftValue | |
777 | THEN | |
778 | PutVariableAtAddress(Sym, Exp) | |
779 | ELSE | |
780 | InternalError ('expecting lvalue for this variable which is declared at an explicit address') | |
781 | END | |
782 | END BuildVarAtAddress ; | |
c9fba1bc | 783 | *) |
7401123f GM |
784 | |
785 | ||
786 | (* | |
787 | BuildOptArgInitializer - assigns the constant value symbol, const, to be the | |
788 | initial value of the optional parameter should it be | |
789 | absent. | |
790 | ||
791 | Ptr -> | |
792 | +------------+ | |
793 | | const | | |
794 | |------------| <- Ptr | |
795 | *) | |
796 | ||
c9fba1bc | 797 | (* |
7401123f GM |
798 | PROCEDURE BuildOptArgInitializer ; |
799 | VAR | |
800 | const: CARDINAL ; | |
801 | BEGIN | |
802 | PopT(const) ; | |
803 | PutOptArgInit(GetCurrentScope(), const) | |
804 | END BuildOptArgInitializer ; | |
c9fba1bc | 805 | *) |
7401123f GM |
806 | |
807 | ||
808 | (* | |
809 | InitDesExpr - | |
810 | *) | |
811 | ||
812 | PROCEDURE InitDesExpr (des: CARDINAL) ; | |
813 | VAR | |
814 | e: exprNode ; | |
815 | BEGIN | |
816 | NEW(e) ; | |
817 | WITH e^ DO | |
818 | tag := designator ; | |
819 | CASE tag OF | |
820 | ||
821 | designator: WITH edes DO | |
822 | type := NulSym ; | |
823 | meta := unknown ; | |
824 | tag := designator ; | |
825 | sym := des ; | |
826 | left := NIL | |
827 | END | |
828 | ||
829 | END | |
830 | END ; | |
831 | PushAddress (exprStack, e) | |
832 | END InitDesExpr ; | |
833 | ||
834 | ||
835 | (* | |
836 | DebugNode - | |
837 | *) | |
838 | ||
839 | PROCEDURE DebugNode (d: exprNode) ; | |
840 | BEGIN | |
841 | IF Debugging AND (d#NIL) | |
842 | THEN | |
843 | WITH d^ DO | |
844 | CASE tag OF | |
845 | ||
846 | designator: DebugDes(d) | | |
847 | expr : DebugExpr(d) | | |
848 | leaf : DebugLeaf(d) | | |
849 | unary : DebugUnary(d) | | |
850 | binary : DebugBinary(d) | | |
851 | function : DebugFunction(d) | | |
852 | convert : DebugConvert(d) | |
853 | ||
854 | END | |
855 | END | |
856 | END | |
857 | END DebugNode ; | |
858 | ||
859 | ||
860 | (* | |
861 | DebugDes - | |
862 | *) | |
863 | ||
864 | PROCEDURE DebugDes (d: exprNode) ; | |
865 | BEGIN | |
866 | WITH d^ DO | |
867 | WITH edes DO | |
868 | DebugSym(sym) ; Write(':') ; DebugMeta(meta) ; Write(':') ; DebugType(type) ; | |
869 | WriteString(' = ') ; | |
870 | DebugNode(left) ; | |
871 | WriteLn | |
872 | END | |
873 | END | |
874 | END DebugDes ; | |
875 | ||
876 | ||
877 | (* | |
878 | DebugSym - | |
879 | *) | |
880 | ||
881 | PROCEDURE DebugSym (sym: CARDINAL) ; | |
882 | VAR | |
883 | n: Name ; | |
884 | BEGIN | |
885 | n := GetSymName(sym) ; | |
886 | IF n#NulName | |
887 | THEN | |
888 | WriteKey(n) | |
889 | END ; | |
890 | Write(':') ; WriteCard(sym, 0) | |
891 | END DebugSym ; | |
892 | ||
893 | ||
894 | (* | |
895 | DebugMeta - | |
896 | *) | |
897 | ||
898 | PROCEDURE DebugMeta (m: constType) ; | |
899 | BEGIN | |
900 | CASE m OF | |
901 | ||
902 | unknown : WriteString('unknown') | | |
903 | set : WriteString('set') | | |
904 | str : WriteString('str') | | |
905 | constructor: WriteString('constructor') | | |
906 | array : WriteString('array') | | |
907 | cast : WriteString('cast') | | |
908 | boolean : WriteString('boolean') | | |
909 | ztype : WriteString('ztype') | | |
910 | rtype : WriteString('rtype') | | |
911 | ctype : WriteString('ctype') | | |
912 | procedure : WriteString('procedure') | | |
913 | char : WriteString('ctype') | |
914 | ||
915 | END | |
916 | END DebugMeta ; | |
917 | ||
918 | ||
919 | (* | |
920 | DebugType - | |
921 | *) | |
922 | ||
923 | PROCEDURE DebugType (type: CARDINAL) ; | |
924 | VAR | |
925 | n: Name ; | |
926 | BEGIN | |
927 | WriteString('[type:') ; | |
928 | IF type=NulSym | |
929 | THEN | |
930 | WriteString('<nulsym>') | |
931 | ELSE | |
932 | n := GetSymName(type) ; | |
933 | IF n#NulSym | |
934 | THEN | |
935 | WriteKey(n) | |
936 | END ; | |
937 | Write(':') ; WriteCard(type, 0) | |
938 | END ; | |
939 | Write(']') | |
940 | END DebugType ; | |
941 | ||
942 | ||
943 | (* | |
944 | DebugExpr - | |
945 | *) | |
946 | ||
947 | PROCEDURE DebugExpr (e: exprNode) ; | |
948 | BEGIN | |
949 | WITH e^.eexpr DO | |
950 | WriteString('expr (') ; | |
951 | DebugType(type) ; Write(':') ; | |
952 | DebugMeta(meta) ; Write(' ') ; | |
953 | DebugNode(left) ; | |
954 | WriteString(') ') | |
955 | END | |
956 | END DebugExpr ; | |
957 | ||
958 | ||
959 | (* | |
960 | DebugFunction - | |
961 | *) | |
962 | ||
963 | PROCEDURE DebugFunction (f: exprNode) ; | |
964 | BEGIN | |
965 | WITH f^.efunction DO | |
966 | WriteKey(GetSymName(func)) ; | |
967 | Write('(') ; | |
968 | IF first#NIL | |
969 | THEN | |
970 | DebugNode(first) ; | |
971 | IF second#NIL | |
972 | THEN | |
973 | WriteString(', ') ; | |
974 | DebugNode(second) ; | |
975 | IF third | |
976 | THEN | |
977 | WriteString(', ...') | |
978 | END | |
979 | END | |
980 | END ; | |
981 | Write(')') | |
982 | END | |
983 | END DebugFunction ; | |
984 | ||
985 | ||
986 | (* | |
987 | DebugConvert - | |
988 | *) | |
989 | ||
990 | PROCEDURE DebugConvert (f: exprNode) ; | |
991 | BEGIN | |
992 | WITH f^.econvert DO | |
993 | DebugNode(totype) ; | |
994 | Write('(') ; | |
995 | DebugNode(expr) ; | |
996 | Write(')') | |
997 | END | |
998 | END DebugConvert ; | |
999 | ||
1000 | ||
1001 | (* | |
1002 | DebugLeaf - | |
1003 | *) | |
1004 | ||
1005 | PROCEDURE DebugLeaf (l: exprNode) ; | |
1006 | BEGIN | |
1007 | WITH l^.eleaf DO | |
1008 | WriteString('leaf (') ; | |
1009 | DebugType(type) ; Write(':') ; | |
1010 | DebugMeta(meta) ; Write(':') ; | |
1011 | DebugSym(sym) ; | |
1012 | WriteString(') ') | |
1013 | END | |
1014 | END DebugLeaf ; | |
1015 | ||
1016 | ||
1017 | (* | |
1018 | DebugUnary - | |
1019 | *) | |
1020 | ||
1021 | PROCEDURE DebugUnary (l: exprNode) ; | |
1022 | BEGIN | |
1023 | WITH l^.eunary DO | |
1024 | WriteString('unary (') ; | |
1025 | DebugType(type) ; Write(':') ; | |
1026 | DebugMeta(meta) ; Write(' ') ; | |
1027 | DebugOp(op) ; Write(' ') ; | |
1028 | DebugNode(left) ; | |
1029 | WriteString(') ') | |
1030 | END | |
1031 | END DebugUnary ; | |
1032 | ||
1033 | ||
1034 | (* | |
1035 | DebugBinary - | |
1036 | *) | |
1037 | ||
1038 | PROCEDURE DebugBinary (l: exprNode) ; | |
1039 | BEGIN | |
1040 | WITH l^.ebinary DO | |
1041 | WriteString('unary (') ; | |
1042 | DebugType(type) ; Write(':') ; | |
1043 | DebugMeta(meta) ; Write(' ') ; | |
1044 | DebugNode(left) ; | |
1045 | DebugOp(op) ; Write(' ') ; | |
1046 | DebugNode(right) ; | |
1047 | WriteString(') ') | |
1048 | END | |
1049 | END DebugBinary ; | |
1050 | ||
1051 | ||
1052 | (* | |
1053 | DebugOp - | |
1054 | *) | |
1055 | ||
1056 | PROCEDURE DebugOp (op: Name) ; | |
1057 | BEGIN | |
1058 | WriteKey(op) | |
1059 | END DebugOp ; | |
1060 | ||
1061 | ||
1062 | (* | |
1063 | PushInConstructor - | |
1064 | *) | |
1065 | ||
1066 | PROCEDURE PushInConstructor ; | |
1067 | BEGIN | |
1068 | PushWord(desStack, inDesignator) ; | |
1069 | inDesignator := FALSE | |
1070 | END PushInConstructor ; | |
1071 | ||
1072 | ||
1073 | (* | |
1074 | PopInConstructor - | |
1075 | *) | |
1076 | ||
1077 | PROCEDURE PopInConstructor ; | |
1078 | BEGIN | |
1079 | inDesignator := PopWord(desStack) | |
1080 | END PopInConstructor ; | |
1081 | ||
1082 | ||
1083 | (* | |
1084 | StartDesConst - | |
1085 | *) | |
1086 | ||
1087 | PROCEDURE StartDesConst ; | |
1088 | VAR | |
1089 | name: Name ; | |
1090 | tok : CARDINAL ; | |
1091 | BEGIN | |
1092 | inDesignator := TRUE ; | |
1093 | exprStack := KillStackAddress (exprStack) ; | |
1094 | exprStack := InitStackAddress () ; | |
1095 | PopTtok (name, tok) ; | |
1096 | InitDesExpr (RequestSym (tok, name)) | |
1097 | END StartDesConst ; | |
1098 | ||
1099 | ||
1100 | (* | |
1101 | EndDesConst - | |
1102 | *) | |
1103 | ||
1104 | PROCEDURE EndDesConst ; | |
1105 | VAR | |
1106 | d, e: exprNode ; | |
1107 | BEGIN | |
1108 | e := PopAddress (exprStack) ; | |
1109 | d := PopAddress (exprStack) ; | |
1110 | Assert(d^.tag=designator) ; | |
1111 | d^.edes.left := e ; | |
1112 | IncludeIndiceIntoIndex(constList, d) ; | |
1113 | inDesignator := FALSE | |
1114 | END EndDesConst ; | |
1115 | ||
1116 | ||
1117 | (* | |
1118 | fixupProcedureType - creates a proctype from a procedure. | |
1119 | *) | |
1120 | ||
1121 | PROCEDURE fixupProcedureType (p: CARDINAL) : CARDINAL ; | |
1122 | VAR | |
1123 | tok : CARDINAL ; | |
1124 | par, | |
1125 | t : CARDINAL ; | |
1126 | n, i: CARDINAL ; | |
1127 | BEGIN | |
1128 | IF IsProcedure(p) | |
1129 | THEN | |
1130 | tok := GetTokenNo () ; | |
1131 | t := MakeProcType(tok, CheckAnonymous(NulName)) ; | |
1132 | i := 1 ; | |
1133 | n := NoOfParam(p) ; | |
1134 | WHILE i<=n DO | |
1135 | par := GetParam(p, i) ; | |
1136 | IF IsParameterVar(par) | |
1137 | THEN | |
1138 | PutProcTypeVarParam(t, GetType(par), IsParameterUnbounded(par)) | |
1139 | ELSE | |
1140 | PutProcTypeParam(t, GetType(par), IsParameterUnbounded(par)) | |
1141 | END ; | |
1142 | INC(i) | |
1143 | END ; | |
1144 | IF GetType(p)#NulSym | |
1145 | THEN | |
1146 | PutFunction(t, GetType(p)) | |
1147 | END ; | |
1148 | RETURN( t ) | |
1149 | ELSE | |
1150 | InternalError ('expecting a procedure') | |
1151 | END ; | |
1152 | RETURN( NulSym ) | |
1153 | END fixupProcedureType ; | |
1154 | ||
1155 | ||
1156 | (* | |
1157 | InitFunction - | |
1158 | *) | |
1159 | ||
1160 | PROCEDURE InitFunction (m: constType; p, t: CARDINAL; f, s: exprNode; more: BOOLEAN) ; | |
1161 | VAR | |
1162 | n: exprNode ; | |
1163 | BEGIN | |
1164 | NEW(n) ; | |
1165 | WITH n^ DO | |
1166 | tag := function ; | |
1167 | CASE tag OF | |
1168 | ||
1169 | function: WITH efunction DO | |
1170 | meta := m ; | |
1171 | type := t ; | |
1172 | func := p ; | |
1173 | first := f ; | |
1174 | second := s ; | |
1175 | third := more | |
1176 | END | |
1177 | ||
1178 | END | |
1179 | END ; | |
1180 | PushAddress(exprStack, n) | |
1181 | END InitFunction ; | |
1182 | ||
1183 | ||
1184 | (* | |
1185 | InitConvert - | |
1186 | *) | |
1187 | ||
1188 | PROCEDURE InitConvert (m: constType; t: CARDINAL; to, e: exprNode) ; | |
1189 | VAR | |
1190 | n: exprNode ; | |
1191 | BEGIN | |
1192 | NEW(n) ; | |
1193 | WITH n^ DO | |
1194 | tag := convert ; | |
1195 | CASE tag OF | |
1196 | ||
1197 | convert: WITH econvert DO | |
1198 | type := t ; | |
1199 | meta := m ; | |
1200 | totype := to ; | |
1201 | expr := e | |
1202 | END | |
1203 | ||
1204 | END | |
1205 | END ; | |
1206 | PushAddress(exprStack, n) | |
1207 | END InitConvert ; | |
1208 | ||
1209 | ||
1210 | (* | |
1211 | InitLeaf - | |
1212 | *) | |
1213 | ||
1214 | PROCEDURE InitLeaf (m: constType; s, t: CARDINAL) ; | |
1215 | VAR | |
1216 | l: exprNode ; | |
1217 | BEGIN | |
1218 | NEW(l) ; | |
1219 | WITH l^ DO | |
1220 | tag := leaf ; | |
1221 | CASE tag OF | |
1222 | ||
1223 | leaf: WITH eleaf DO | |
1224 | type := t ; | |
1225 | meta := m ; | |
1226 | sym := s | |
1227 | END | |
1228 | ||
1229 | END | |
1230 | END ; | |
1231 | PushAddress(exprStack, l) | |
1232 | END InitLeaf ; | |
1233 | ||
1234 | ||
1235 | (* | |
1236 | InitProcedure - | |
1237 | *) | |
1238 | ||
1239 | PROCEDURE InitProcedure (s: CARDINAL) ; | |
1240 | BEGIN | |
1241 | InitLeaf(procedure, s, fixupProcedureType(s)) | |
1242 | END InitProcedure ; | |
1243 | ||
1244 | ||
1245 | (* | |
1246 | InitCharType - | |
1247 | *) | |
1248 | ||
1249 | PROCEDURE InitCharType (s: CARDINAL) ; | |
1250 | BEGIN | |
1251 | InitLeaf(char, s, Char) | |
1252 | END InitCharType ; | |
1253 | ||
1254 | ||
1255 | (* | |
1256 | InitZType - | |
1257 | *) | |
1258 | ||
1259 | PROCEDURE InitZType (s: CARDINAL) ; | |
1260 | BEGIN | |
1261 | InitLeaf(ztype, s, ZType) | |
1262 | END InitZType ; | |
1263 | ||
1264 | ||
1265 | (* | |
1266 | InitRType - | |
1267 | *) | |
1268 | ||
1269 | PROCEDURE InitRType (s: CARDINAL) ; | |
1270 | BEGIN | |
1271 | InitLeaf(rtype, s, RType) | |
1272 | END InitRType ; | |
1273 | ||
1274 | ||
1275 | (* | |
1276 | InitUnknown - | |
1277 | *) | |
1278 | ||
1279 | PROCEDURE InitUnknown (s: CARDINAL) ; | |
1280 | BEGIN | |
1281 | InitLeaf(unknown, s, NulSym) | |
1282 | END InitUnknown ; | |
1283 | ||
1284 | ||
1285 | (* | |
1286 | InitBooleanType - | |
1287 | *) | |
1288 | ||
1289 | PROCEDURE InitBooleanType (s: CARDINAL) ; | |
1290 | BEGIN | |
1291 | InitLeaf(boolean, s, Boolean) | |
1292 | END InitBooleanType ; | |
1293 | ||
1294 | ||
1295 | (* | |
1296 | PushConstType - pushes a constant to the expression stack. | |
1297 | *) | |
1298 | ||
1299 | PROCEDURE PushConstType ; | |
1300 | VAR | |
1301 | c: CARDINAL ; | |
1302 | BEGIN | |
1303 | PopT(c) ; | |
1304 | PushT(c) ; | |
1305 | IF inDesignator | |
1306 | THEN | |
1307 | IF c=NulSym | |
1308 | THEN | |
1309 | WriteFormat0('module or symbol in qualident is not known') ; | |
1310 | FlushErrors ; | |
1311 | InitUnknown(c) | |
1312 | ELSIF IsProcedure(c) | |
1313 | THEN | |
1314 | InitProcedure(c) | |
1315 | ELSIF GetSkippedType(c)=RType | |
1316 | THEN | |
1317 | InitRType(c) | |
1318 | ELSIF GetSkippedType(c)=ZType | |
1319 | THEN | |
1320 | InitZType(c) | |
1321 | ELSIF GetSkippedType(c)=Boolean | |
1322 | THEN | |
1323 | InitBooleanType(c) | |
1324 | ELSE | |
1325 | InitUnknown(c) | |
1326 | END | |
1327 | END | |
1328 | END PushConstType ; | |
1329 | ||
1330 | ||
1331 | (* | |
1332 | PushConstructorCastType - | |
1333 | *) | |
1334 | ||
1335 | PROCEDURE PushConstructorCastType ; | |
1336 | VAR | |
1337 | c: CARDINAL ; | |
1338 | BEGIN | |
1339 | PopT(c) ; | |
1340 | PushT(c) ; | |
1341 | IF inDesignator | |
1342 | THEN | |
1343 | InitConvert(cast, c, NIL, NIL) | |
1344 | END | |
1345 | END PushConstructorCastType ; | |
1346 | ||
1347 | ||
1348 | (* | |
1349 | TypeToMeta - | |
1350 | *) | |
1351 | ||
1352 | PROCEDURE TypeToMeta (type: CARDINAL) : constType ; | |
1353 | BEGIN | |
1354 | IF type=Char | |
1355 | THEN | |
1356 | RETURN( char ) | |
1357 | ELSIF type=Boolean | |
1358 | THEN | |
1359 | RETURN( boolean ) | |
1360 | ELSIF IsRealType(type) | |
1361 | THEN | |
1362 | RETURN( rtype ) | |
1363 | ELSIF IsComplexType(type) | |
1364 | THEN | |
1365 | RETURN( ctype ) | |
1366 | ELSIF IsOrdinalType(type) | |
1367 | THEN | |
1368 | RETURN( ztype ) | |
1369 | ELSE | |
1370 | RETURN( unknown ) | |
1371 | END | |
1372 | END TypeToMeta ; | |
1373 | ||
1374 | ||
1375 | (* | |
1376 | buildConstFunction - we are only concerned about resolving the return type o | |
1377 | a function, so we can ignore all parameters - except | |
1378 | the first one in the case of VAL(type, foo). | |
1379 | buildConstFunction uses a unary exprNode to represent | |
1380 | a function. | |
1381 | *) | |
1382 | ||
1383 | PROCEDURE buildConstFunction (func: CARDINAL; n: CARDINAL) ; | |
1384 | VAR | |
1385 | i : CARDINAL ; | |
1386 | f, s: exprNode ; | |
1387 | BEGIN | |
1388 | f := NIL ; | |
1389 | s := NIL ; | |
1390 | IF n=1 | |
1391 | THEN | |
1392 | f := PopAddress(exprStack) | |
1393 | ELSIF n>=2 | |
1394 | THEN | |
1395 | i := n ; | |
1396 | WHILE i>2 DO | |
1397 | s := PopAddress(exprStack) ; | |
1398 | DISPOSE(s) ; | |
1399 | DEC(i) | |
1400 | END ; | |
1401 | s := PopAddress(exprStack) ; | |
1402 | f := PopAddress(exprStack) | |
1403 | END ; | |
1404 | IF func=Val | |
1405 | THEN | |
1406 | InitConvert(cast, NulSym, f, s) | |
1407 | ELSIF (func=Max) OR (func=Min) | |
1408 | THEN | |
1409 | InitFunction(unknown, func, NulSym, f, s, FALSE) | |
1410 | ELSE | |
1411 | InitFunction(TypeToMeta(GetSkippedType(func)), func, GetSkippedType(func), f, s, n>2) | |
1412 | END | |
1413 | END buildConstFunction ; | |
1414 | ||
1415 | ||
1416 | (* | |
1417 | PushConstFunctionType - | |
1418 | *) | |
1419 | ||
1420 | PROCEDURE PushConstFunctionType ; | |
1421 | VAR | |
1422 | func: CARDINAL ; | |
1423 | n : CARDINAL ; | |
1424 | BEGIN | |
1425 | PopT(n) ; | |
1426 | PopT(func) ; | |
1427 | IF inDesignator | |
1428 | THEN | |
1429 | IF (func#Convert) AND | |
1430 | (IsPseudoBaseFunction(func) OR | |
1431 | IsPseudoSystemFunctionConstExpression(func) OR | |
1432 | (IsProcedure(func) AND IsProcedureBuiltin(func))) | |
1433 | THEN | |
1434 | buildConstFunction(func, n) | |
1435 | ELSIF IsAModula2Type(func) | |
1436 | THEN | |
1437 | IF n=1 | |
1438 | THEN | |
1439 | (* the top element on the expression stack is the first and only parameter to the cast *) | |
1440 | InitUnary(cast, func, GetSymName(func)) | |
1441 | ELSE | |
1442 | WriteFormat0('a constant type conversion can only have one argument') | |
1443 | END | |
1444 | ELSE | |
1445 | IF Iso | |
1446 | THEN | |
1447 | WriteFormat0('the only functions permissible in a constant expression are: CAP, CHR, CMPLX, FLOAT, HIGH, IM, LENGTH, MAX, MIN, ODD, ORD, RE, SIZE, TSIZE, TRUNC, VAL and gcc builtins') | |
1448 | ELSE | |
1449 | WriteFormat0('the only functions permissible in a constant expression are: CAP, CHR, FLOAT, HIGH, MAX, MIN, ODD, ORD, SIZE, TSIZE, TRUNC, VAL and gcc builtins') | |
1450 | END | |
1451 | END | |
1452 | END ; | |
1453 | PushT(func) | |
1454 | END PushConstFunctionType ; | |
1455 | ||
1456 | ||
1457 | (* | |
1458 | PushIntegerType - | |
1459 | *) | |
1460 | ||
1461 | PROCEDURE PushIntegerType ; | |
1462 | VAR | |
1463 | sym: CARDINAL ; | |
1464 | m : constType ; | |
1465 | BEGIN | |
1466 | PopT(sym) ; | |
1467 | IF inDesignator | |
1468 | THEN | |
1469 | m := TypeToMeta(GetSkippedType(sym)) ; | |
1470 | IF m=char | |
1471 | THEN | |
1472 | InitCharType(sym) | |
1473 | ELSE | |
1474 | InitZType(sym) | |
1475 | END | |
1476 | END | |
1477 | END PushIntegerType ; | |
1478 | ||
1479 | ||
1480 | (* | |
1481 | PushRType - | |
1482 | *) | |
1483 | ||
1484 | PROCEDURE PushRType ; | |
1485 | VAR | |
1486 | sym: CARDINAL ; | |
1487 | BEGIN | |
1488 | PopT(sym) ; | |
1489 | IF inDesignator | |
1490 | THEN | |
1491 | InitRType(sym) | |
1492 | END | |
1493 | END PushRType ; | |
1494 | ||
1495 | ||
1496 | (* | |
1497 | PushStringType - | |
1498 | *) | |
1499 | ||
1500 | PROCEDURE PushStringType ; | |
1501 | VAR | |
1502 | sym: CARDINAL ; | |
1503 | BEGIN | |
1504 | PopT(sym) ; | |
1505 | IF inDesignator | |
1506 | THEN | |
1507 | InitLeaf(str, sym, NulSym) | |
1508 | END | |
1509 | END PushStringType ; | |
1510 | ||
1511 | ||
1512 | (* | |
1513 | InitBinary - | |
1514 | *) | |
1515 | ||
1516 | PROCEDURE InitBinary (m: constType; t: CARDINAL; o: Name) ; | |
1517 | VAR | |
1518 | l, r, b: exprNode ; | |
1519 | BEGIN | |
1520 | r := PopAddress(exprStack) ; | |
1521 | l := PopAddress(exprStack) ; | |
1522 | NEW(b) ; | |
1523 | WITH b^ DO | |
1524 | tag := binary ; | |
1525 | CASE tag OF | |
1526 | ||
1527 | binary: WITH ebinary DO | |
1528 | meta := m ; | |
1529 | type := t ; | |
1530 | left := l ; | |
1531 | right := r ; | |
1532 | op := o | |
1533 | END | |
1534 | END | |
1535 | END ; | |
1536 | PushAddress(exprStack, b) | |
1537 | END InitBinary ; | |
1538 | ||
1539 | ||
1540 | (* | |
1541 | BuildRelationConst - builds a relationship binary operation. | |
1542 | *) | |
1543 | ||
1544 | PROCEDURE BuildRelationConst ; | |
1545 | VAR | |
1546 | op: Name ; | |
1547 | BEGIN | |
1548 | PopT(op) ; | |
1549 | IF inDesignator | |
1550 | THEN | |
1551 | InitBinary(boolean, Boolean, op) | |
1552 | END | |
1553 | END BuildRelationConst ; | |
1554 | ||
1555 | ||
1556 | (* | |
1557 | BuildBinaryConst - builds a binary operator node. | |
1558 | *) | |
1559 | ||
1560 | PROCEDURE BuildBinaryConst ; | |
1561 | VAR | |
1562 | op: Name ; | |
1563 | BEGIN | |
1564 | PopT(op) ; | |
1565 | IF inDesignator | |
1566 | THEN | |
1567 | InitBinary(unknown, NulSym, op) | |
1568 | END | |
1569 | END BuildBinaryConst ; | |
1570 | ||
1571 | ||
1572 | (* | |
1573 | InitUnary - | |
1574 | *) | |
1575 | ||
1576 | PROCEDURE InitUnary (m: constType; t: CARDINAL; o: Name) ; | |
1577 | VAR | |
1578 | l, b: exprNode ; | |
1579 | BEGIN | |
1580 | l := PopAddress(exprStack) ; | |
1581 | NEW(b) ; | |
1582 | WITH b^ DO | |
1583 | tag := unary ; | |
1584 | CASE tag OF | |
1585 | ||
1586 | unary: WITH eunary DO | |
1587 | meta := m ; | |
1588 | type := t ; | |
1589 | left := l ; | |
1590 | op := o | |
1591 | END | |
1592 | ||
1593 | END | |
1594 | END ; | |
1595 | PushAddress(exprStack, b) | |
1596 | END InitUnary ; | |
1597 | ||
1598 | ||
1599 | (* | |
1600 | BuildUnaryConst - builds a unary operator node. | |
1601 | *) | |
1602 | ||
1603 | PROCEDURE BuildUnaryConst ; | |
1604 | VAR | |
1605 | op: Name ; | |
1606 | BEGIN | |
1607 | PopT(op) ; | |
1608 | IF inDesignator | |
1609 | THEN | |
1610 | InitUnary(unknown, NulSym, op) | |
1611 | END | |
1612 | END BuildUnaryConst ; | |
1613 | ||
1614 | ||
1615 | (* | |
1616 | isTypeResolved - | |
1617 | *) | |
1618 | ||
1619 | PROCEDURE isTypeResolved (e: exprNode) : BOOLEAN ; | |
1620 | BEGIN | |
1621 | WITH e^ DO | |
1622 | CASE tag OF | |
1623 | ||
1624 | leaf : RETURN( (eleaf.type#NulSym) OR (eleaf.meta=str) ) | | |
1625 | unary : RETURN( (eunary.type#NulSym) OR (eunary.meta=str) ) | | |
1626 | binary : RETURN( (ebinary.type#NulSym) OR (ebinary.meta=str) ) | | |
1627 | designator: RETURN( (edes.type#NulSym) OR (edes.meta=str) ) | | |
1628 | expr : RETURN( (eexpr.type#NulSym) OR (eexpr.meta=str) ) | | |
1629 | convert : RETURN( (econvert.type#NulSym) OR (econvert.meta=str) ) | | |
1630 | function : RETURN( (efunction.type#NulSym) OR (efunction.meta=str) ) | |
1631 | ||
1632 | END | |
1633 | END | |
1634 | END isTypeResolved ; | |
1635 | ||
1636 | ||
1637 | (* | |
1638 | getEtype - | |
1639 | *) | |
1640 | ||
1641 | PROCEDURE getEtype (e: exprNode) : CARDINAL ; | |
1642 | BEGIN | |
1643 | WITH e^ DO | |
1644 | CASE tag OF | |
1645 | ||
1646 | leaf : RETURN( eleaf.type ) | | |
1647 | unary : RETURN( eunary.type ) | | |
1648 | binary : RETURN( ebinary.type ) | | |
1649 | designator: RETURN( edes.type ) | | |
1650 | expr : RETURN( eexpr.type ) | | |
1651 | convert : RETURN( econvert.type ) | | |
1652 | function : RETURN( efunction.type ) | |
1653 | ||
1654 | END | |
1655 | END | |
1656 | END getEtype ; | |
1657 | ||
1658 | ||
1659 | (* | |
1660 | getEmeta - | |
1661 | *) | |
1662 | ||
1663 | PROCEDURE getEmeta (e: exprNode) : constType ; | |
1664 | BEGIN | |
1665 | WITH e^ DO | |
1666 | CASE tag OF | |
1667 | ||
1668 | leaf : RETURN( eleaf.meta ) | | |
1669 | unary : RETURN( eunary.meta ) | | |
1670 | binary : RETURN( ebinary.meta ) | | |
1671 | designator: RETURN( edes.meta ) | | |
1672 | expr : RETURN( eexpr.meta ) | | |
1673 | convert : RETURN( econvert.meta ) | | |
1674 | function : RETURN( efunction.meta ) | |
1675 | ||
1676 | END | |
1677 | END | |
1678 | END getEmeta ; | |
1679 | ||
1680 | ||
1681 | (* | |
1682 | assignTM - | |
1683 | *) | |
1684 | ||
1685 | PROCEDURE assignTM (VAR td: CARDINAL; VAR md: constType; te: CARDINAL; me: constType) ; | |
1686 | BEGIN | |
1687 | md := me ; | |
1688 | td := te | |
1689 | END assignTM ; | |
1690 | ||
1691 | ||
1692 | (* | |
1693 | assignType - | |
1694 | *) | |
1695 | ||
1696 | PROCEDURE assignType (d, e: exprNode) ; | |
1697 | VAR | |
1698 | t: CARDINAL ; | |
1699 | m: constType ; | |
1700 | BEGIN | |
1701 | m := getEmeta(e) ; | |
1702 | t := getEtype(e) ; | |
1703 | WITH d^ DO | |
1704 | CASE tag OF | |
1705 | ||
1706 | leaf : assignTM(eleaf.type, eleaf.meta, t, m) | | |
1707 | unary : assignTM(eunary.type, eunary.meta, t, m) | | |
1708 | binary : assignTM(ebinary.type, ebinary.meta, t, m) | | |
1709 | designator: assignTM(edes.type, edes.meta, t, m) | | |
1710 | expr : assignTM(eexpr.type, eexpr.meta, t, m) | | |
1711 | convert : assignTM(econvert.type, econvert.meta, t, m) | | |
1712 | function : assignTM(efunction.type, efunction.meta, t, m) | |
1713 | ||
1714 | END | |
1715 | END | |
1716 | END assignType ; | |
1717 | ||
1718 | ||
1719 | (* | |
1720 | deduceTypes - works out the type and metatype given, l, and, r. | |
1721 | *) | |
1722 | ||
1723 | PROCEDURE deduceTypes (VAR t: CARDINAL; | |
1724 | VAR m: constType; | |
1725 | l, r: exprNode; op: Name) ; | |
1726 | BEGIN | |
1727 | IF r=NIL | |
1728 | THEN | |
1729 | (* function or cast *) | |
1730 | t := getEtype(l) ; | |
1731 | m := getEmeta(l) | |
1732 | ELSIF (op=EqualTok) OR (op=HashTok) OR (op=LessGreaterTok) OR | |
1733 | (op=LessTok) OR (op=LessEqualTok) OR (op=GreaterTok) OR | |
1734 | (op=GreaterEqualTok) OR (op=InTok) OR (op=OrTok) OR | |
1735 | (op=AndTok) OR (op=NotTok) OR (op=AmbersandTok) | |
1736 | THEN | |
1737 | t := Boolean ; | |
1738 | m := boolean | |
1739 | ELSIF (op=PlusTok) OR (op=MinusTok) OR (op=TimesTok) OR (op=ModTok) OR | |
1740 | (op=DivTok) OR (op=RemTok) OR (op=DivideTok) | |
1741 | THEN | |
1742 | t := MixTypes(getEtype(l), getEtype(r), constToken) ; | |
1743 | m := getEmeta(l) ; | |
1744 | IF m=unknown | |
1745 | THEN | |
1746 | m := getEmeta(r) | |
1747 | ELSIF (getEmeta(r)#unknown) AND (m#getEmeta(r)) | |
1748 | THEN | |
1749 | ErrorFormat0(NewError(constToken), | |
1750 | 'the operands to a binary constant expression have different types') | |
1751 | END | |
1752 | ELSE | |
1753 | InternalError ('unexpected operator') | |
1754 | END | |
1755 | END deduceTypes ; | |
1756 | ||
1757 | ||
1758 | (* | |
1759 | WalkConvert - | |
1760 | *) | |
1761 | ||
1762 | PROCEDURE WalkConvert (e: exprNode) : BOOLEAN ; | |
1763 | BEGIN | |
1764 | IF isTypeResolved(e) | |
1765 | THEN | |
1766 | RETURN( FALSE ) | |
1767 | ELSE | |
1768 | WITH e^.econvert DO | |
1769 | IF isTypeResolved(totype) | |
1770 | THEN | |
1771 | assignType(e, totype) ; | |
1772 | RETURN( TRUE ) | |
1773 | END ; | |
1774 | RETURN( doWalkNode(totype) ) | |
1775 | END | |
1776 | END | |
1777 | END WalkConvert ; | |
1778 | ||
1779 | ||
1780 | (* | |
1781 | WalkFunctionParam - | |
1782 | *) | |
1783 | ||
1784 | PROCEDURE WalkFunctionParam (func: CARDINAL; e: exprNode) : BOOLEAN ; | |
1785 | BEGIN | |
1786 | IF isTypeResolved(e) | |
1787 | THEN | |
1788 | RETURN( FALSE ) | |
1789 | ELSE | |
1790 | IF e^.tag=leaf | |
1791 | THEN | |
1792 | WITH e^.eleaf DO | |
1793 | IF (sym#NulSym) AND (type=NulSym) | |
1794 | THEN | |
1795 | IF (func=Min) OR (func=Max) | |
1796 | THEN | |
1797 | IF IsEnumeration(sym) OR IsSet(sym) | |
1798 | THEN | |
1799 | type := SkipType(GetType(sym)) | |
1800 | ELSE | |
1801 | (* sym is the type required for MAX, MIN and VAL *) | |
1802 | type := sym | |
1803 | END | |
1804 | ELSE | |
1805 | Assert(func=Val) ; | |
1806 | type := sym | |
1807 | END ; | |
1808 | meta := TypeToMeta(sym) ; | |
1809 | RETURN( TRUE ) | |
1810 | END | |
1811 | END | |
1812 | END | |
1813 | END ; | |
1814 | RETURN( FALSE ) | |
1815 | END WalkFunctionParam ; | |
1816 | ||
1817 | ||
1818 | (* | |
1819 | WalkFunction - | |
1820 | *) | |
1821 | ||
1822 | PROCEDURE WalkFunction (e: exprNode) : BOOLEAN ; | |
1823 | BEGIN | |
1824 | IF isTypeResolved(e) | |
1825 | THEN | |
1826 | RETURN( FALSE ) | |
1827 | ELSE | |
1828 | WITH e^.efunction DO | |
1829 | IF (func=Max) OR (func=Min) OR (func=Val) | |
1830 | THEN | |
1831 | IF isTypeResolved(first) | |
1832 | THEN | |
1833 | IF getEmeta(first)=str | |
1834 | THEN | |
1835 | MetaError1('a string parameter cannot be passed to function {%1Dad}', func) ; | |
1836 | RETURN( FALSE ) | |
1837 | END ; | |
1838 | type := getEtype(first) ; | |
1839 | RETURN( TRUE ) | |
1840 | END ; | |
1841 | RETURN( WalkFunctionParam(func, first) ) | |
1842 | ELSE | |
1843 | MetaError1('not expecting this function inside a constant expression {%1Dad}', func) | |
1844 | END | |
1845 | END | |
1846 | END | |
1847 | END WalkFunction ; | |
1848 | ||
1849 | ||
1850 | (* | |
1851 | doWalkNode - | |
1852 | *) | |
1853 | ||
1854 | PROCEDURE doWalkNode (e: exprNode) : BOOLEAN ; | |
1855 | BEGIN | |
1856 | WITH e^ DO | |
1857 | CASE tag OF | |
1858 | ||
1859 | expr : RETURN( WalkExpr(e) ) | | |
1860 | leaf : RETURN( WalkLeaf(e) ) | | |
1861 | unary : RETURN( WalkUnary(e) ) | | |
1862 | binary : RETURN( WalkBinary(e) ) | | |
1863 | convert : RETURN( WalkConvert(e) ) | | |
1864 | function: RETURN( WalkFunction(e) ) | |
1865 | ||
1866 | ELSE | |
1867 | InternalError ('unexpected tag value') | |
1868 | END | |
1869 | END ; | |
1870 | RETURN( FALSE ) | |
1871 | END doWalkNode ; | |
1872 | ||
1873 | ||
1874 | (* | |
1875 | WalkLeaf - | |
1876 | *) | |
1877 | ||
1878 | PROCEDURE WalkLeaf (e: exprNode) : BOOLEAN ; | |
1879 | VAR | |
1880 | c: exprNode ; | |
1881 | BEGIN | |
1882 | IF isTypeResolved(e) | |
1883 | THEN | |
1884 | RETURN( FALSE ) | |
1885 | ELSE | |
1886 | WITH e^.eleaf DO | |
1887 | IF sym=13 | |
1888 | THEN | |
1889 | stop | |
1890 | END ; | |
1891 | IF IsConst(sym) AND (GetType(sym)#NulSym) | |
1892 | THEN | |
1893 | type := GetSkippedType(sym) ; | |
1894 | RETURN( TRUE ) | |
1895 | END ; | |
1896 | IF IsAModula2Type(sym) | |
1897 | THEN | |
1898 | type := sym ; | |
1899 | RETURN( TRUE ) | |
1900 | END ; | |
1901 | c := findConstDes(sym) ; | |
1902 | IF (c#NIL) AND isTypeResolved(c) | |
1903 | THEN | |
1904 | assignType(e, c) ; | |
1905 | RETURN( TRUE ) | |
1906 | END | |
1907 | END | |
1908 | END ; | |
1909 | RETURN( FALSE ) | |
1910 | END WalkLeaf ; | |
1911 | ||
1912 | ||
1913 | (* | |
1914 | WalkUnary - | |
1915 | *) | |
1916 | ||
1917 | PROCEDURE WalkUnary (e: exprNode) : BOOLEAN ; | |
1918 | BEGIN | |
1919 | IF isTypeResolved(e) | |
1920 | THEN | |
1921 | RETURN( FALSE ) | |
1922 | ELSE | |
1923 | WITH e^.eunary DO | |
1924 | IF isTypeResolved(left) | |
1925 | THEN | |
1926 | deduceTypes(type, meta, left, left, op) ; | |
1927 | RETURN( TRUE ) | |
1928 | END ; | |
1929 | RETURN( doWalkNode(left) ) | |
1930 | END | |
1931 | END | |
1932 | END WalkUnary ; | |
1933 | ||
1934 | ||
1935 | (* | |
1936 | WalkBinary - | |
1937 | *) | |
1938 | ||
1939 | PROCEDURE WalkBinary (e: exprNode) : BOOLEAN ; | |
1940 | VAR | |
1941 | changed: BOOLEAN ; | |
1942 | BEGIN | |
1943 | IF isTypeResolved(e) | |
1944 | THEN | |
1945 | RETURN( FALSE ) | |
1946 | ELSE | |
1947 | WITH e^.ebinary DO | |
1948 | IF isTypeResolved(left) AND isTypeResolved(right) | |
1949 | THEN | |
1950 | deduceTypes(type, meta, left, right, op) ; | |
1951 | RETURN( TRUE ) | |
1952 | END ; | |
1953 | changed := doWalkNode(left) ; | |
1954 | RETURN( doWalkNode(right) OR changed ) | |
1955 | END | |
1956 | END | |
1957 | END WalkBinary ; | |
1958 | ||
1959 | ||
1960 | (* | |
1961 | WalkExpr - | |
1962 | *) | |
1963 | ||
1964 | PROCEDURE WalkExpr (e: exprNode) : BOOLEAN ; | |
1965 | BEGIN | |
1966 | IF isTypeResolved(e) | |
1967 | THEN | |
1968 | RETURN( FALSE ) | |
1969 | ELSE | |
1970 | WITH e^.eexpr DO | |
1971 | IF isTypeResolved(left) | |
1972 | THEN | |
1973 | assignType(e, left) ; | |
1974 | RETURN( TRUE ) | |
1975 | END ; | |
1976 | RETURN( doWalkNode(left) ) | |
1977 | END | |
1978 | END | |
1979 | END WalkExpr ; | |
1980 | ||
1981 | ||
1982 | (* | |
1983 | doWalkDesExpr - returns TRUE if the expression trees, d, or, e, are changed. | |
1984 | *) | |
1985 | ||
1986 | PROCEDURE doWalkDesExpr (d, e: exprNode) : BOOLEAN ; | |
1987 | BEGIN | |
1988 | IF isTypeResolved(e) | |
1989 | THEN | |
1990 | WITH d^.edes DO | |
1991 | type := getEtype(e) ; | |
1992 | IF type=NulSym | |
1993 | THEN | |
1994 | meta := getEmeta(e) ; | |
1995 | IF meta=str | |
1996 | THEN | |
1997 | (* PutConstString(sym, getString(e)) *) | |
1998 | END | |
1999 | ELSE | |
2000 | PutConst(sym, type) | |
2001 | END ; | |
2002 | RETURN( TRUE ) | |
2003 | END | |
2004 | END ; | |
2005 | RETURN( doWalkNode(e) ) | |
2006 | END doWalkDesExpr ; | |
2007 | ||
2008 | ||
2009 | (* | |
2010 | doWalkDes - return TRUE if expression, e, is changed. | |
2011 | *) | |
2012 | ||
2013 | PROCEDURE doWalkDes (d: exprNode) : BOOLEAN ; | |
2014 | BEGIN | |
2015 | IF isTypeResolved(d) | |
2016 | THEN | |
2017 | RETURN( FALSE ) | |
2018 | ELSE | |
2019 | WITH d^ DO | |
2020 | CASE tag OF | |
2021 | ||
2022 | designator: WITH edes DO | |
2023 | constToken := GetDeclaredMod(sym) ; | |
2024 | RETURN( doWalkDesExpr(d, left) ) | |
2025 | END | |
2026 | ||
2027 | ELSE | |
2028 | InternalError ('unexpected tag value') | |
2029 | END | |
2030 | END | |
2031 | END | |
2032 | END doWalkDes ; | |
2033 | ||
2034 | ||
2035 | (* | |
2036 | findConstDes - | |
2037 | *) | |
2038 | ||
2039 | PROCEDURE findConstDes (sym: CARDINAL) : exprNode ; | |
2040 | VAR | |
2041 | i: CARDINAL ; | |
2042 | e: exprNode ; | |
2043 | BEGIN | |
2044 | i := 1 ; | |
2045 | WHILE i<=HighIndice(constList) DO | |
2046 | e := GetIndice(constList, i) ; | |
2047 | WITH e^ DO | |
2048 | CASE tag OF | |
2049 | ||
2050 | designator: IF edes.sym=sym | |
2051 | THEN | |
2052 | RETURN( e ) | |
2053 | END | |
2054 | ||
2055 | ELSE | |
2056 | END | |
2057 | END ; | |
2058 | INC(i) | |
2059 | END ; | |
2060 | RETURN( NIL ) | |
2061 | END findConstDes ; | |
2062 | ||
2063 | ||
2064 | (* | |
2065 | WalkDes - return TRUE if expression, e, is changed. | |
2066 | *) | |
2067 | ||
2068 | PROCEDURE WalkDes (d: exprNode) : BOOLEAN ; | |
2069 | BEGIN | |
2070 | IF d=NIL | |
2071 | THEN | |
2072 | RETURN( FALSE ) | |
2073 | ELSE | |
2074 | RETURN( doWalkDes(d) ) | |
2075 | END | |
2076 | END WalkDes ; | |
2077 | ||
2078 | ||
2079 | (* | |
2080 | WalkConst - returns TRUE if the constant tree associated with, sym, | |
2081 | is changed. | |
2082 | *) | |
2083 | ||
257e9cda | 2084 | (* |
7401123f GM |
2085 | PROCEDURE WalkConst (sym: CARDINAL) : BOOLEAN ; |
2086 | BEGIN | |
2087 | RETURN( WalkDes(findConstDes(sym)) ) | |
2088 | END WalkConst ; | |
257e9cda | 2089 | *) |
7401123f GM |
2090 | |
2091 | ||
2092 | (* | |
2093 | WalkConsts - walk over the constant trees and return TRUE if any tree was changed. | |
2094 | (As a result of a type resolution). | |
2095 | *) | |
2096 | ||
2097 | PROCEDURE WalkConsts () : BOOLEAN ; | |
2098 | VAR | |
2099 | changed: BOOLEAN ; | |
2100 | i : CARDINAL ; | |
2101 | BEGIN | |
2102 | changed := FALSE ; | |
2103 | i := 1 ; | |
2104 | WHILE i<=HighIndice(constList) DO | |
2105 | IF WalkDes(GetIndice(constList, i)) | |
2106 | THEN | |
2107 | changed := TRUE | |
2108 | END ; | |
2109 | INC(i) | |
2110 | END ; | |
2111 | RETURN( changed ) | |
2112 | END WalkConsts ; | |
2113 | ||
2114 | ||
2115 | (* | |
2116 | DebugNodes - | |
2117 | *) | |
2118 | ||
2119 | PROCEDURE DebugNodes ; | |
2120 | VAR | |
2121 | i: CARDINAL ; | |
2122 | BEGIN | |
2123 | i := 1 ; | |
2124 | WHILE i<=HighIndice(constList) DO | |
2125 | IF isTypeResolved(GetIndice(constList, i)) | |
2126 | THEN | |
2127 | WriteString('resolved ') | |
2128 | ELSE | |
2129 | WriteString('unresolved ') | |
2130 | END ; | |
2131 | DebugNode(GetIndice(constList, i)) ; WriteLn ; | |
2132 | INC(i) | |
2133 | END | |
2134 | END DebugNodes ; | |
2135 | ||
2136 | ||
2137 | (* | |
2138 | findAlias - | |
2139 | *) | |
2140 | ||
2141 | PROCEDURE findAlias (sym: CARDINAL; e: exprNode) : CARDINAL ; | |
2142 | BEGIN | |
2143 | CASE e^.tag OF | |
2144 | ||
2145 | designator: RETURN( findAlias(sym, e^.edes.left) ) | | |
2146 | leaf : RETURN( e^.eleaf.sym ) | | |
2147 | expr : RETURN( findAlias(sym, e^.eexpr.left) ) | | |
2148 | unary, | |
2149 | binary : RETURN( sym ) | |
2150 | ||
2151 | ELSE | |
2152 | InternalError ('not expecting this tag value') | |
2153 | END | |
2154 | END findAlias ; | |
2155 | ||
2156 | ||
2157 | (* | |
2158 | SkipConst - returns an alias to constant, sym, if one exists. | |
2159 | Otherwise sym is returned. | |
2160 | *) | |
2161 | ||
2162 | PROCEDURE SkipConst (sym: CARDINAL) : CARDINAL ; | |
2163 | VAR | |
2164 | i: CARDINAL ; | |
2165 | e: exprNode ; | |
2166 | BEGIN | |
2167 | i := 1 ; | |
2168 | WHILE i<=HighIndice(constList) DO | |
2169 | e := GetIndice(constList, i) ; | |
2170 | IF (e^.tag=designator) AND (e^.edes.sym=sym) | |
2171 | THEN | |
2172 | RETURN( findAlias(sym, e) ) | |
2173 | END ; | |
2174 | INC(i) | |
2175 | END ; | |
2176 | RETURN( sym ) | |
2177 | END SkipConst ; | |
2178 | ||
2179 | ||
2180 | (* | |
2181 | PushConstAttributeType - | |
2182 | *) | |
2183 | ||
2184 | PROCEDURE PushConstAttributeType ; | |
2185 | VAR | |
2186 | n: Name ; | |
2187 | BEGIN | |
2188 | PopT(n) ; | |
2189 | PushT(n) ; | |
2190 | InitZType(NulSym) ; | |
2191 | IF (n=MakeKey('BITS_PER_UNIT')) OR (n=MakeKey('BITS_PER_WORD')) OR | |
2192 | (n=MakeKey('BITS_PER_CHAR')) OR (n=MakeKey('UNITS_PER_WORD')) | |
2193 | THEN | |
2194 | (* all ok *) | |
2195 | ELSE | |
2196 | WriteFormat1("unknown constant attribute value '%a'", n) | |
2197 | END | |
2198 | END PushConstAttributeType ; | |
2199 | ||
2200 | ||
2201 | (* | |
2202 | PushConstAttributePairType - | |
2203 | *) | |
2204 | ||
2205 | PROCEDURE PushConstAttributePairType ; | |
2206 | VAR | |
2207 | q, n: Name ; | |
2208 | BEGIN | |
2209 | PopT(n) ; | |
2210 | PopT(q) ; | |
2211 | PushT(q) ; | |
2212 | PushT(n) ; | |
2213 | IF (n=MakeKey('IEC559')) OR (n=MakeKey('LIA1')) OR (n=MakeKey('IEEE')) OR | |
2214 | (n=MakeKey('ISO')) OR (n=MakeKey('rounds')) OR (n=MakeKey('gUnderflow')) OR | |
2215 | (n=MakeKey('exception')) OR (n=MakeKey('extend')) | |
2216 | THEN | |
2217 | InitBooleanType(NulSym) | |
2218 | ELSIF (n=MakeKey('radix')) OR (n=MakeKey('places')) OR (n=MakeKey('expoMin')) OR | |
2219 | (n=MakeKey('expoMax')) OR (n=MakeKey('nModes')) | |
2220 | THEN | |
2221 | InitZType(NulSym) | |
2222 | ELSIF (n=MakeKey('large')) OR (n=MakeKey('small')) | |
2223 | THEN | |
2224 | InitRType(NulSym) | |
2225 | ELSE | |
2226 | WriteFormat1("unknown constant attribute value '%a'", n) ; | |
2227 | InitUnknown(NulSym) | |
2228 | END | |
2229 | END PushConstAttributePairType ; | |
2230 | ||
2231 | ||
2232 | (* | |
2233 | CheckConsts - | |
2234 | *) | |
2235 | ||
2236 | PROCEDURE CheckConsts ; | |
2237 | VAR | |
2238 | i: CARDINAL ; | |
2239 | e: exprNode ; | |
2240 | BEGIN | |
2241 | i := 1 ; | |
2242 | WHILE i<=HighIndice(constList) DO | |
2243 | e := GetIndice(constList, i) ; | |
2244 | IF NOT isTypeResolved(e) | |
2245 | THEN | |
2246 | WITH e^ DO | |
2247 | CASE tag OF | |
2248 | ||
2249 | designator: MetaError1('the type of the constant declaration {%1Dad} cannot be determined', edes.sym) | |
2250 | ||
2251 | ELSE | |
2252 | END | |
2253 | END | |
2254 | END ; | |
2255 | INC(i) | |
2256 | END | |
2257 | END CheckConsts ; | |
2258 | ||
2259 | ||
2260 | (* | |
2261 | ResolveConstTypes - resolves the types of all designator declared constants. | |
2262 | *) | |
2263 | ||
2264 | PROCEDURE ResolveConstTypes ; | |
2265 | BEGIN | |
2266 | IF Debugging | |
2267 | THEN | |
2268 | WriteString('initially') ; WriteLn ; | |
2269 | DebugNodes | |
2270 | END ; | |
2271 | WHILE WalkConsts() DO | |
2272 | IF Debugging | |
2273 | THEN | |
2274 | WriteString('iteration') ; WriteLn ; | |
2275 | DebugNodes | |
2276 | END | |
2277 | END ; | |
2278 | IF Debugging | |
2279 | THEN | |
2280 | WriteString('finally') ; WriteLn ; | |
2281 | DebugNodes | |
2282 | END ; | |
2283 | CheckConsts | |
2284 | END ResolveConstTypes ; | |
2285 | ||
2286 | ||
2287 | (* | |
2288 | Init - | |
2289 | *) | |
2290 | ||
2291 | PROCEDURE Init ; | |
2292 | BEGIN | |
2293 | exprStack := InitStackAddress () ; | |
2294 | constList := InitIndex (1) ; | |
2295 | desStack := InitStackWord () ; | |
2296 | inDesignator := FALSE | |
2297 | END Init ; | |
2298 | ||
2299 | ||
2300 | BEGIN | |
2301 | Init | |
2302 | END PCSymBuild. |