1 * *************************************************************************
2 * *
3 * Copyright c 1980 by Centre Interuniversitaire de Calcul de Grenoble *
4 * and Institut National de Recherche en Informatique et Automatique *
5 * *
6 ************************************************************************* *
7
8
9
10
11 * HISTORY COMMENTS:
12 1 change86-09-11JMAthane, approve86-09-11MCR7521,
13 audit86-09-15JPFauche, install86-11-12MR12.0-1212:
14 Release 8.03 for MR12
15 END HISTORY COMMENTS *)
16
17
18 $OPTIONS page $
19
20 $OPTIONS switch trace := true ; switch security := true ; t + $
21 PROGRAM state ;
22 $IMPORT
23 * IMPORTED VARIABLES *
24 'GENERE pascal' :
25 cb,
26 codesymb,
27 indfich,
28 mfari1,
29 mfari2,
30 tagsymb,
31 usednameaddr ;
32 'RACINE pascal' :
33 boxheader,
34 charptr,
35 chnix,
36 ctptr,
37 display,
38 disx,
39 errtotal,
40 intptr,
41 level,
42 mpcogout,
43 nilptr,
44 no,
45 realptr,
46 string_ptr,
47 symbolfile,
48 symbolline,
49 symbolmap,
50 undecptr,
51 undlab,
52 version ;
53 * IMPORTED PROCEDURES *
54 'GENERE pascal' :
55 gendesca,
56 gendescb,
57 geneism,
58 genstand,
59 inser ;
60 'RACINE pascal' :
61 error,
62 insymbol,
63 nameisref,
64 nextline,
65 recadre,
66 sup ;
67 'UNIQUE pascal' :
68 heaperror ;
69 'CONTEXTTABLE pascal ' :
70 create_types_box,
71 create_konst_box,
72 create_vars_box,
73 findminmax,
74 packedsize ;
75 'MODATTR pascal ' :
76 freeattr,
77 initattrvarbl,
78 isstring,
79 lvalvarbl,
80 printattr ;
81 'MODVARIABLE pascal ' :
82 init_desc_address,
83 variable ;
84 'optimized_procedures alm' :
85 search $
86
87 $EXPORT
88 addressvar,
89 arrayboundsctp,
90 asscheck,
91 calcvarient,
92 checkbnds,
93 choicerarq,
94 cltransf,
95 currentbloc,
96 currentpr,
97 currlcstpt,
98 currllcstpt,
99 currrcstpt,
100 currwithlist,
101 currwcstpt,
102 disposeused,
103 resetused,
104 divcheck,
105 entercst,
106 enterlcst,
107 enterllcst,
108 enterundlab,
109 errorctp,
110 freeallregisters,
111 freebloc,
112 gattr,
113 gencheckmultover,
114 gencstecode,
115 genexceptcode,
116 getpr,
117 inbounds,
118 initstate,
119 inputctp,
120 inxcheck,
121 lcsave,
122 linktoend,
123 linktoendplace,
124 linktomain,
125 linktomainplace,
126 loadadr,
127 loadbase,
128 maxinxused,
129 maxprused,
130 modif,
131 newbloc,
132 nilanaq,
133 nileraq,
134 nulpw,
135 oldnewstor,
136 opaq,
137 outputctp,
138 prinst,
139 printstatusregister,
140 psrsize,
141 raisused,
142 regenere,
143 regname,
144 revcltransf,
145 rqisused,
146 sauvereg,
147 stack_extension,
148 stack_has_been_extended,
149 stattrace,
150 tabacc,
151 tabkind,
152 tempstor,
153 tmax,
154 transfer,
155 variab,
156 variabctptr,
157 withvariable,
158 workformaths,
159 workformathsplacew $
160
161
162
163
164
165 $OPTIONS page $
166
167 $INCLUDE 'CONSTTYPE' $
168
169
170
171 $OPTIONS page $
172
173 VAR
174 * *** REDEFINE IMPORTED VARIABLES * *
175 * FROM GENERE *
176 cb : integer ;
177 codesymb : ARRAY instword OF alfa ;
178 indfich : integer ;
179 mfari1 : zari ;
180 mfari2 : zari ;
181 tagsymb : ARRAY tag OF PACKED ARRAY 1..4 OF char ;
182 usednameaddr : ctp ;
183 * FROM DECLARE *
184 * FROM RACINE *
185 boxheader : PACKED ARRAY 1..120 OF char ;
186 harptr : ctp ;
187 charptr : ctp ;
188 chnix : integer ;
189 ctptr : ctp ;
190 display : ARRAY 0..displimit OF recidscope ;
191 disx : integer ;
192 errtotal : integer ;
193 intptr : ctp ;
194 level : levrange ;
195 mpcogout : text ; nilptr : ctp ;
196 no : integer ;
197 realptr : ctp ;
198 string_ptr : ctp ;
199 symbolfile : integer ;
200 symbolline : integer ;
201 symbolmap : boolean ;
202 undecptr : ctp ;
203 undlab : ARRAY 1..undmax OF occurence ;
204 version : integer ;
205
206
207 * EXPORTABLE VARIABLES *
208
209 arrayboundsctp : ctp ; * DUMMY BOX FOR CHECKBNDSARRAYS *
210 asscheck : boolean ; * SET IN INSYMBOL T+A+ FOR ASSIGN CHECK *
211 cltransf : ARRAY 1..6 OF integer ; * GIVES THE TRANSF CORR. TO OPER. 8CL *
212 currentbloc : regpt ; * LAST CREATED BOX REGISTER *
213 currentpr : preg ; * GIVES THE POINTER REGISTER GET BY GETPR *
214 currlcstpt : lcstpt ; * " " LONG CONSTANT *
215 currllcstpt : llcstpt ; * " " SET " *
216 currrcstpt : rcstpt ; * " " REAL " *
217 currwithlist : withreflist ;
218 currwcstpt : wcstpt ; * " " WORD " *
219 disposeused : boolean ;
220 resetused : boolean ;
221 divcheck : boolean ; * ZERO DIVIDE CHECK *
222 errorctp : ctp ;
223 gattr : attr ; * GLOBAL ATTR *
224 inputctp : ctp ; * BOX PREDECLARED FOR INPUT *
225 inxcheck : boolean ; * SET BY X+ FOR INDEX *
226 lcsave : integer ; * SAVING OF LC *
227 linktoend : boolean ;
228 linktoendplace : integer ;
229 linktomain : boolean ;
230 linktomainplace : integer ;
231 maxinxused : register ; * LAST INDEX REGISTER USED IN GETINDEX *
232 maxprused : preg ; * LAST POINTER REGISTER USED IN GETPR *
233 modif : ARRAY nxreg..rq OF tag ; * GIVES FOR A REGISTER R ITS TAG TR *
234 nilanaq,
235 nileraq : setarray ; * USED FOR NIL COMPARISONS *
236 nulpw : setarray ; * EMPTY SET *
237 opaq : ARRAY typeofop ra..reaq OF istand ; * GIVES INST. WITH AQAQEAQ *
238 outputctp : ctp ; * BOX PREDECLARED FOR OUTPUT *
239 prinst : ARRAY typepr pr1..pr6 OF istand ; * GIVES A PR INSTRUCTION *
240 psrsize : integer ; * USEFULL SIZE OF PSR *
241 regname : ARRAY register OF PACKED ARRAY 1..4 OF char ; * REGIST. NAMES *
242 revcltransf : ARRAY 1..6 OF integer ; * GIVES 8CL --> REVERSE TRANSF *
243 stack_has_been_extended : boolean ;
244 stattrace : levtrace ; * TRACE FOR MODULE STATEMENT *
245 tabacc : ARRAY attraccess OF alfa ; * MNEMONICS USED IN TRACE *
246 tabkind : ARRAY attrkind OF alfa ; * MNEMONICS USED IN TRACE *
247 variabctptr : ctp ;
248 tempstor : integer ; * FREE STORAGE IN STACK *
249 tmax : integer ; * MAX REACHED IN CURRENT FRAME *
250 withvariable : boolean ; * TRUE IF IN WITH CONTROL VARIABLE ANALYSIS *
251 workformaths : boolean ; * TRUE IF WORK AREA ALLOCATED IN CURRENT FRAME FOR MATH OPS *
252 workformathsplacew : integer ; * OFFSET IN CURR STACK FRAME OF THIS WORK AREA *
253
254
255 * LOCAL VARIABLES *
256
257 begfreelist : regpt ; * FIRST FREE REGISTER BOX *
258 currentindex : register ; * GIVES THE INDEX REGISTER GET BY GETINDEX *
259 dummybloc : regpt ; * DUMMY REGISTER BOX *
260 forgetbox : integer ; * USED TO KNOW THE FORGOTTEN REG BOX *
261 freereg : statearray ; * FALSE FOR ALL REGISTERS *
262 newtagstar : ARRAY tn..tx7 OF tag ; * GIVES FOR A TAG TR --> TRY *
263 nilpseudoset : setarray ; * USED TO GENERATE NIL "ITS" *
264 regcharge : statearray ; * GIVES THE LOADIND STATES OF THE REGISTERS *
265 saved_stack_end_place : integer ;
266 starmodif : ARRAY nxreg..rq OF tag ; * GIVES FOR A REGISTER R --> TAG TRY *
267 sversion : integer ; * VERSION OF STATE *
268 xinst : ARRAY typix x0..x7 OF istand ; * GIVES AN ALM INSTRUCTION WITH XI *
269
270
271 $OPTIONS page $
272
273 $VALUE
274
275 cltransf = 7 8 9 10 6 2 ;
276 maxinxused = x5 ;
277 maxprused = pr7 ;
278 modif = tn tx0 tx1 tx2 tx3 tx4 tx5 tx6 tx7 tn tal tql ;
279 nilanaq = '1FFFC003F'x 'FFFFC7E3F'x 6 * 0 ;
280 nileraq = '1FFFC0023'x '000040000'x 6 * 0 ;
281 nulpw = 8 * 0 ;
282 opaq = ilda ildq ildaq idfld
283 isba isbq isbaq idfsb
284 ials iqls ills inop
285 iada iadq iadaq idfad
286 ineg inop inegl ifneg
287 icmpa icmpq icmpaq idfcmp
288 ista istq istaq idfst ;
289 prinst = iepp1 iepp2 iepp5 iepp7 iepp3 iepp0 iepp4 iepp4 iepp6
290 ispri1 ispri2 ispri5 ispri7 ispri3 ispri0 ispri4 ispri4 ispri6
291 ilprp1 ilprp2 ilprp5 ilprp7 ilprp3 ilprp0 ilprp4 ilprp4 ilprp6 ;
292 regname = 'NRG ' 'PR1 ' 'PR2 ' 'PR5 ' 'PR7 ' 'PR3 ' 'PR0 ' 'PRST' 'PRLK' 'PR6 '
293 'NXR ' ' X0 ' ' X1 ' ' X2 ' ' X3 ' ' X4 ' ' X5 ' ' X6 ' ' X7 '
294 ' ' ' A ' ' Q ' ' AQ ' 'EAQ ' 'PSR ' ' E ' ' I ' ;
295 revcltransf = 10 9 8 7 6 2 ;
296 tabacc = ' DIRECT ' 'POINTEE ' 'POINTABL' ;
297 tabkind = ' VARBL ' ' LCOND ' ' LVAL ' ' CHAIN ' ' SVAL ' ;
298
299 freereg = 27 * false ;
300 newtagstar = tny tauy tquy tz23 ticy taly tqly tz27
301 tx0y tx1y tx2y tx3y tx4y tx5y tx6y tx7y ;
302 nilpseudoset = nilleft nilright 6 * 0 ;
303 starmodif = tny tyx0 tyx1 tyx2 tyx3 tyx4 tyx5 tyx6
304 tyx7 tny tyal tyql ;
305 xinst =
306 iadlx0 iadlx1 iadlx2 iadlx3 iadlx4 iadlx5 iadlx6 iadlx7
307 iadx0 iadx1 iadx2 iadx3 iadx4 iadx5 iadx6 iadx7
308 isxl0 isxl1 isxl2 isxl3 isxl4 isxl5 isxl6 isxl7
309 ilxl0 ilxl1 ilxl2 ilxl3 ilxl4 ilxl5 ilxl6 ilxl7
310 $
311
312 $OPTIONS page $
313
314 * *** NOW REDEFINE IMPORTED PROCEDURE *
315
316
317 * FROM GENERE *
318 PROCEDURE genstand fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag ; EXTERNAL ;
319 PROCEDURE geneism fcode : ieism ; ffield : integer ; fbits : zptr ; EXTERNAL ;
320 PROCEDURE gendesca fareg : preg ; fadr fcn : integer ; fta : lgcar ;
321 fn : integer ; frlgth : mreg ; EXTERNAL ;
322 PROCEDURE gendescb fareg : preg ; fadr fc fb : integer ; fn : integer ;
323 frlgth : mreg ; EXTERNAL ;
324 PROCEDURE inser fcb : integer ; fplace : integer ; EXTERNAL ;
325 * FROM RACINE *
326 PROCEDURE error errno : integer ; EXTERNAL ;
327 PROCEDURE insymbol ; EXTERNAL ;
328 PROCEDURE nameisref p : ctp ; f l : integer ; EXTERNAL ;
329 PROCEDURE nextline ; EXTERNAL ;
330 FUNCTION recadre fnum fmod : integer : integer ; EXTERNAL ;
331 PROCEDURE search ; EXTERNAL ;
332 FUNCTION sup fval1 fval2 : integer : integer ; EXTERNAL ;
333
334 * FROM UNIQUE *
335 PROCEDURE heaperror ; EXTERNAL ;
336
337 * FROM MODVARIABLE *
338
339 PROCEDURE init_desc_address fctptr : ctp ; VAR fattr : attr ; EXTERNAL ;
340 PROCEDURE variable fvarset : boolean ; EXTERNAL ;
341
342 * FROM CONTEXTTABLE *
343
344 PROCEDURE create_types_box VAR fvbox : ctp ; fname : alfaid ; fform : typform ; fbool : boolean ; EXTERNAL ;
345 PROCEDURE create_konst_box VAR fvbox : ctp ; fname : alfaid ; ftypofconst : consttype ; EXTERNAL ;
346 PROCEDURE create_vars_box VAR fvbox : ctp ; fname : alfaid ; EXTERNAL ;
347 PROCEDURE findminmax fctp : ctp ; VAR fmin fmax : integer ; EXTERNAL ;
348 FUNCTION packedsize fctp : ctp : integer ; EXTERNAL ;
349
350 * FROM MODATTR *
351
352 PROCEDURE freeattr VAR fattr : attr ; EXTERNAL ;
353 PROCEDURE initattrvarbl VAR fattr : attr ; EXTERNAL ;
354 FUNCTION isstring VAR fattr : attr : boolean ; EXTERNAL ;
355 PROCEDURE lvalvarbl VAR fattr : attr ; EXTERNAL ;
356 PROCEDURE printattr VAR fattr : attr ; EXTERNAL ;
357
358
359
360 $OPTIONS page $
361
362 * ************************************ PRINTREGBOX *************************** *
363
364 $OPTIONS compile = trace $
365 PROCEDURE printregbox fptbox : regpt ;
366
367 * C CALLED WHEN STATTRACE IS HIGH TO PRINT THE CONTENT OF A
368 SPECIFIED REGISTER_STATE_BOX
369 C *
370 BEGIN * PRINTREGBOX *
371 nextline ; write mpcogout boxheader ; nextline ;
372 IF fptbox = NIL THEN
373 BEGIN
374 write mpcogout '* REGBOX REQUESTED IS NIL. TRACE STOPS' ; nextline ;
375 END ELSE
376 BEGIN
377 write mpcogout '* REGISTER BOX FOLLOWING IS AT @' ord fptbox ; nextline ;
378 WITH fptbox@ DO
379 BEGIN
380 write mpcogout '* REGISTER IS ' regname sregister ' SAVEPLACE IS :'
381 saveplace : 6 ; nextline ;
382 write mpcogout '* NEXTBLOC AND PREDBLOC ARE AT @' ord nextbloc ' AND AT @'
383 ord predbloc ; nextline ;
384 END ;
385 END ;
386 write mpcogout boxheader ; nextline ; nextline ;
387 END * PRINTREGBOX * ;
388 $OPTIONS compile = true $
389
390
391 $OPTIONS page $
392
393 * ************************************ PRINTSTATUSREGISTER ****************** *
394
395 PROCEDURE printstatusregister ;
396
397 * C CALLED IN TRACE CONTEXT IN ORDER TO EDIT THE LOADED REGISTERS C *
398 VAR
399 lreg : register ;
400 BEGIN
401 write mpcogout '*** REGISTERS LOADED ARE:' ;
402 FOR lreg := pr1 TO maxprused DO
403 IF regcharge lreg THEN write mpcogout regname lreg : 5 ;
404 FOR lreg := x0 TO maxinxused DO
405 IF regcharge lreg THEN write mpcogout regname lreg : 5 ;
406 FOR lreg := ra TO psr DO
407 IF regcharge lreg THEN write mpcogout regname lreg : 5 ;
408 nextline ;
409 END * PRINTSTATUSREGISTER * ;
410
411
412
413 $OPTIONS page $
414
415 * ******************************************** INITSTATE ********************* *
416
417 PROCEDURE initstate ;
418
419 * C INIT ALLL VARIABLES OF STATE C *
420 VAR
421 it : integer ;
422 lastcreate, wkpt : regpt ;
423 BEGIN
424 create_types_box arrayboundsctp blank numeric false ;
425 WITH arrayboundsctp^ DO
426 BEGIN
427 size := bytesinword ; cadrage := bytesinword ;
428 npksize := size ;
429 * NMIN and NMAX filled each time before use *
430 END ;
431 * INITIALIZATION OF REGISTER'S BOXES LIST *
432 new dummybloc ; IF dummybloc = NIL THEN heaperror ; * EXIT COMP. *
433 WITH dummybloc@ DO
434 BEGIN
435 sregister := nreg ; saveplace := 0 ; predbloc := NIL ;
436 nextbloc := NIL ;
437 END ;
438 currentbloc := dummybloc ;
439 lastcreate := NIL ;
440 FOR it := 1 TO longboxlist DO
441 BEGIN
442 new wkpt ; IF wkpt = NIL THEN heaperror ; * EXIT COMP. *
443 WITH wkpt@ DO
444 BEGIN
445 IF lastcreate = NIL THEN
446 begfreelist := wkpt ELSE
447 lastcreate@.nextbloc := wkpt ;
448 lastcreate := wkpt ;
449 nextbloc := NIL ; predbloc := NIL ;
450 END * WITH * ;
451 END ; * FOR IT *
452 forgetbox := 0 ;
453 stack_has_been_extended := false ;
454 stattrace := none ;
455 errorctp := NIL ;
456 inputctp := NIL ;
457 outputctp := NIL ;
458 linktomain := false ;
459 linktoend := false ;
460 sversion := 00 ;
461 IF sversion > version THEN version := sversion ;
462 withvariable := false ;
463 disposeused := false ;
464 resetused := false ;
465 END * INITSTATE * ;
466
467
468 $OPTIONS page $
469
470 * ************************************ ENTERCST ****************************** *
471
472 PROCEDURE entercst fval : integer ; VAR fboxpt : wcstpt ;
473
474 * C . SEARCHES IF "FVAL" IS ALREADY PRESENT IN THE LIST BEGINNING AT
475 CURRWCSTPT.
476 IF YES RETURNS THE POINTER ON IT
477 IF NO RETURNS THE NEWLY CREATED BOX . " "FVAL" CSTPLACE CSTNEXT
478 C *
479 * E ERRORS DETECTED
480 HEAPERROR
481 E *
482 LABEL
483 1 ; * EXIT SEARCH'S WHILE *
484 VAR
485 workpt : wcstpt ;
486 BEGIN * ENTERCST *
487 $OPTIONS compile = trace $
488 IF stattrace > none THEN
489 BEGIN
490 write mpcogout '@@@ DEBUT ENTERCST @@@ WITH FVAL:' fval ; nextline ;
491 END ;
492 $OPTIONS compile = true $
493 workpt := currwcstpt ; * LAST CREATED BOX *
494 * NIL FOR THE FIRST ENTERED CSTE *
495 WHILE workpt # NIL DO
496 IF workpt@.valu = fval THEN
497 GOTO 1 * ASSIGNS FBOXPTEXIT PROC * ELSE
498 workpt := workpt@.cstnext ;
499 * AT THIS POINT CST NOT FOUND *
500 new workpt ; IF workpt = NIL THEN heaperror ; * EXIT COMP *
501 WITH workpt@ DO
502 BEGIN valu := fval ; cstnext := currwcstpt ; * CHAINS BOXES *
503 cstplace := 0 ; * INIT CHAIN OF UNRESOLVED *
504 * REFERENCES IN UNDLAB *
505 END ;
506 currwcstpt := workpt ;
507 $OPTIONS compile = trace $
508 IF stattrace = high THEN
509 BEGIN
510 write mpcogout boxheader ; nextline ;
511 write mpcogout '* W.CONST BOX CREATED AT @' ord workpt ' NEXT BOX AT @'
512 ord workpt@.cstnext ' VALU IS:' fval ; nextline ;
513 write mpcogout boxheader ; nextline ;
514 END ;
515 $OPTIONS compile = true $
516 1 : fboxpt := workpt ; * EITHER EXIT WHILE EITHER NEW BOX CREATED *
517 $OPTIONS compile = trace $
518 IF stattrace > low THEN
519 BEGIN write mpcogout '@@@ FIN ENTERCST @@@ WITH V.FBOXPT AT @' ord fboxpt ;
520 nextline ;
521 END ;
522 $OPTIONS compile = true $
523 END * ENTERCST * ;
524
525
526 $OPTIONS page $
527
528 * ************************************ ENTERLCST ***************************** *
529
530 PROCEDURE enterlcst VAR fval : setarray ; VAR fboxpt : lcstpt ;
531
532 * C SEARCHS IF THE TWO-WORDS CONSTANT FVAL0FVAL1 IS ALREADY IN THE CHAIN
533 WHOSE HEAD IS POINTED BY CURRLCSTPT.
534 IF NO CREATES A NEW BOX LUNRESOLV
535 RETURNED POINTER POINTS THE EITHER FOUND OR CREATED BOX
536 C *
537 * E ERRORS DETECTED
538 HEAPERROR
539 E *
540 LABEL
541 1 ; * EXIT WHILE *
542 VAR
543 workpt : lcstpt ;
544 BEGIN * ENTERLCST *
545 $OPTIONS compile = trace $
546 IF stattrace > none THEN
547 BEGIN
548 write mpcogout '@@@ DEBUT ENTERLCST @@@ WITH FVAL0FVAL1 :' fval 0 : 14
549 fval 1 : 14 ;
550 nextline ;
551 END ;
552 $OPTIONS compile = true $
553 workpt := currlcstpt ; * LAST CREATED CSTE *
554 WHILE workpt # NIL DO
555 BEGIN
556 IF workpt@.lvalu 0 = fval 0 THEN
557 IF workpt@.lvalu 1 = fval 1 THEN
558 GOTO 1 ; * ASSIGNS FBOXPT AND EXIT PROC *
559 workpt := workpt@.lnext ;
560 END ; * WHILE *
561 * CSTE NOT FOUND ==> CREATES A NEW BOX *
562 new workpt ; IF workpt = NIL THEN heaperror ; * EXIT COMP *
563 WITH workpt@ DO
564 BEGIN
565 lvalu := fval ;
566 lplace := 0 ; * INIT CHAIN OF UNRESOLVED REF. *
567 lnext := currlcstpt ;
568 END ;
569 currlcstpt := workpt ;
570 $OPTIONS compile = trace $
571 IF stattrace = high THEN
572 BEGIN
573 write mpcogout boxheader ; nextline ;
574 write mpcogout '* LCONST BOX CREATED AT @' ord workpt ; nextline ;
575 nextline ;
576 write mpcogout boxheader ; nextline ;
577 END ;
578 $OPTIONS compile = true $
579 * <--- *
580 1 :
581 fboxpt := workpt ;
582 $OPTIONS compile = trace $
583 IF stattrace > low THEN
584 BEGIN
585 write mpcogout '@@@ FIN ENTERLCST @@@ WITH V.FBOXPT AT @' ord fboxpt ; nextline ;
586 END ;
587 $OPTIONS compile = true $
588 END * ENTERLCST * ;
589
590
591 $OPTIONS page $
592
593 * ************************************ ENTERLLCST **************************** *
594
595 PROCEDURE enterllcst VAR fval : setarray ; VAR fboxpt : llcstpt ;
596
597 * C.SEARCHES IF THE SET CONSTANT FVAL IS ALREADY IN THE CHAIN BEGINNING AT
598 CURRLLCSTPT
599 .IF YES RETURNS A POINTER ON IT ELSE CREATES A NEW BOX AND RETURNS THE
600 NEW POINTER
601 C *
602 * E ERRORS DETECTED
603 HEAPERROR EXIT COMP
604 E *
605 LABEL
606 1 ; * EXIT WHILE *
607 VAR
608 workpt : llcstpt ;
609 it : integer ;
610 equal : boolean ;
611 BEGIN * ENTERLLCST *
612 $OPTIONS compile = trace $
613 IF stattrace > none THEN
614 BEGIN
615 write mpcogout '@@@ DEBUT ENTERLLCST @@@' ; nextline ;
616 END ;
617 $OPTIONS compile = true $
618 workpt := currllcstpt ;
619 WHILE workpt # NIL DO
620 BEGIN
621 equal := true ;
622 FOR it := 0 TO bornesupset DO IF fval it # workpt@.llvalu it THEN
623 equal := false ;
624 IF equal THEN
625 * <=== * GOTO 1 ELSE
626 workpt := workpt@.llnext ;
627 END ; * WHILE *
628 * FVAL NOT FOUND. THEN CREATES A NEW BOX *
629 new workpt ; IF workpt = NIL THEN heaperror ; * EXIT COMP *
630 WITH workpt@ DO
631 BEGIN llvalu := fval ; llnext := currllcstpt ; llplace := 0 ; * LATER ON UNDLAB *
632 END ;
633 currllcstpt := workpt ;
634 $OPTIONS compile = trace $
635 IF stattrace = high THEN
636 BEGIN
637 write mpcogout boxheader ; nextline ;
638 write mpcogout '* LLCONST BOX CREATED AT @' ord workpt ' LLNEXT IS AT @'
639 ord workpt@.llnext ; nextline ;
640 FOR it := 0 TO bornesupset DO write mpcogout workpt@.llvalu it : 15 ; nextline ;
641 write mpcogout boxheader ; nextline ;
642 END ;
643 $OPTIONS compile = true $
644 * <==== *
645 1 : fboxpt := workpt ;
646 $OPTIONS compile = trace $
647 IF stattrace > low THEN
648 BEGIN
649 write mpcogout '@@@ FIN ENTERLLCST @@@ WITH V.FBOXPT AT @' ord fboxpt ;
650 nextline ;
651 END ;
652 $OPTIONS compile = true $
653 END * ENTERLLCST * ;
654
655
656 $OPTIONS page $
657
658 * ************************************ ENTERREAL ***************************** *
659
660 PROCEDURE enterreal frval : real ; VAR fboxpt : rcstpt ;
661
662 * C SEARCHES IN LIST BEGINNING AT CURRRCSTPT IF FRVAL EXISTS.
663 IF YES RETURNS POINTER ON THIS BOX
664 ELSE CREATES A NEW BOX.
665 C *
666 * E ERRORS DETECTED
667 HEAPERROR
668 E *
669 LABEL
670 1 ; * EXIT WHILE *
671 VAR
672 workpt : rcstpt ;
673 BEGIN
674 $OPTIONS compile = trace $
675 IF stattrace > none THEN
676 BEGIN
677 write mpcogout '@@@ DEBUT ENTERREAL @@@ WITH FRVAL:' frval ; nextline ;
678 END ;
679 $OPTIONS compile = true $
680 workpt := currrcstpt ;
681 WHILE workpt # NIL DO
682 IF workpt@.rvalu = frval THEN
683 BEGIN
684 GOTO 1 ; * ASSIGNS FBOXPT ; EXIT PROC *
685 END ELSE
686 workpt := workpt@.rnext ;
687 * HERE NOT FOUND *
688 new workpt ; IF workpt = NIL THEN heaperror ; * EXIT COMP *
689 WITH workpt@ DO
690 BEGIN
691 rvalu := frval ; rplace := 0 ; * INIT FUTURE CHAIN IN UNDLAB *
692 rnext := currrcstpt ;
693 END ;
694 currrcstpt := workpt ;
695 $OPTIONS compile = trace $
696 IF stattrace = high THEN
697 BEGIN
698 write mpcogout boxheader ; nextline ;
699 write mpcogout '* REAL CONSTANT BOX CREATED AT @' ord workpt ; nextline ;
700 WITH workpt@ DO
701 write mpcogout '* RVALU IS: ' rvalu ' RNEXT IS AT @' ord rnext ;
702 nextline ;
703 write mpcogout boxheader ; nextline ;
704 END ;
705 $OPTIONS compile = true $
706 * <=== *
707 1 : fboxpt := workpt ;
708 $OPTIONS compile = trace $
709 IF stattrace > low THEN
710 BEGIN
711 write mpcogout '@@@ FIN ENTERREAL @@@ WITH V.FBOXPT AT @' ord fboxpt ;
712 nextline ;
713 END ;
714 $OPTIONS compile = true $
715 END * ENTERREAL * ;
716
717
718 $OPTIONS page $
719
720 * ************************************ ENTERUNDLAB *************************** *
721
722 PROCEDURE enterundlab VAR fundinx : integer ;
723
724 * C "FUNDINX IS THE BEGINNING OF A LIST IN UNDLAB OF UNRESOLVED
725 REFERENCES 0 MEANS NO LIST
726 THIS PROCEDURE ADDS A NEW OCCURENCE IN THE LIST OR INITIATE A NEW LIST
727 INDFICH = INDEX IN FICHINTER OF INCOMPLETE INSTRUCTION
728 CHNIX POINTS BEGINNING OF FREE LIST
729 C *
730 * E ERRORS DETECTED
731 261: TOO MANY UNRESOLVED REFERENCES UNDLAB FULL
732 E *
733 VAR
734 it : integer ;
735 BEGIN * ENTERUNDLAB *
736 $OPTIONS compile = trace $
737 IF stattrace > none THEN
738 BEGIN
739 write mpcogout '@@@ DEBUT ENTERUNDLAB @@@ WITH INDFICH CHNIX'
740 indfich : 6 chnix : 6
741 ' FUNDINX IN IS ' fundinx : 6 ; nextline ;
742 END ;
743 $OPTIONS compile = true $
744 IF chnix = 0 THEN * UNDLAB IS FULL *
745 error 261 ELSE
746 WITH undlab chnix DO
747 BEGIN
748 place := indfich ; it := succ ; * FUTURE BEGINNING OF FREE LIST *
749 succ := fundinx ; fundinx := chnix ;
750 chnix := it ;
751 END ;
752 $OPTIONS compile = trace $
753 IF stattrace > low THEN
754 BEGIN
755 write mpcogout '@@@ FIN ENTERUNDLAB @@@ WITH FUNDINXOUT NEW CHNIX ' fundinx : 6
756 chnix : 6 ;
757 nextline ;
758 END ;
759 $OPTIONS compile = true $
760 END * ENTERUNDLAB * ;
761
762
763
764 $OPTIONS page $
765
766 * ************************************ GENEXCEPTCODE ************************* *
767
768 PROCEDURE genexceptcode ferrcode : integer ; freg : register ;
769
770 * C CALL OF AN OPERATOR THAT MUST
771 . PRINTS VALUE OFFSET ERROR MSG
772 . STOPS EXECUTION
773 C *
774 VAR
775 lcode : integer ;
776 BEGIN * GENEXCEPTCODE *
777 $OPTIONS compile = trace $
778 IF stattrace > none THEN
779 BEGIN
780 write mpcogout '@@@ DEBUT_FIN DE GENEXCEPTCODE @@@' ; nextline ;
781 END ;
782 $OPTIONS compile = true $
783 CASE freg OF
784 ra : lcode := 1 ;
785 rq : lcode := 2 ;
786 raq : lcode := 4 ;
787 reaq : lcode := 8 ;
788 END * CASE FREG * ;
789 genstand nreg ferrcode ieax5 tn ;
790 genstand nreg lcode ieax6 tn ;
791 genstand pr0 exceptcodeplace itsp3 tn ;
792 END * GENEXCEPTCODE * ;
793
794
795 $OPTIONS page $
796
797 * ************************************ GENCSTECODE *************************** *
798
799 PROCEDURE gencstecode farg : integer ; finst : istand ;
800
801 * C .AN INSTRUCTION WITH CSTE FARG ARGUMENT MUST BE GENERATE .
802 .THIS PROCEDURE CHECK FOR SINGLE INSTRUCTION OR FOR LARGE CSTE .
803 .IF LARGE CSTE ENTERS IT IN WORD_CSTE LIST AND USES UNRESOLVED
804 MECHANISM
805 C *
806 VAR
807 short : boolean ;
808 locboxpt : wcstpt ;
809 BEGIN * GENCSTECODE *
810 $OPTIONS compile = trace $
811 IF stattrace > none THEN
812 BEGIN
813 write mpcogout '@@@ DEBUT GENCSTECODE @@@ WITH FARGFINST' farg
814 codesymb finst : 9 ;
815 nextline ;
816 END ;
817 $OPTIONS compile = true $
818 short := false ;
819 IF farg >= 0 THEN
820 IF farg < twoto18 THEN
821 short := true ;
822 IF short THEN
823 genstand nreg farg finst tdl ELSE
824 BEGIN * NOT SHORT *
825 entercst farg locboxpt ;
826 enterundlab locboxpt@.cstplace ;
827 * ADDS A NEW OCCUR. OF "FARG" *
828 * IN CHAIN OF UNRESOLVED OCCURENCE *
829 genstand nreg 0 finst tic ;
830 END * NOT SHORT * ;
831 $OPTIONS compile = trace $
832 IF stattrace > low THEN
833 BEGIN
834 write mpcogout '@@@ FIN GENCSTECODE @@@' ; nextline ;
835 END ;
836 $OPTIONS compile = true $
837 END * GENCSTECODE * ;
838
839
840 $OPTIONS page $
841
842 * ************************************** GENCHECKMULTOVER ******************************************** *
843
844 PROCEDURE gencheckmultover ;
845
846 * C THIS PROCEDURE GENERATES CODE TO CHECK OVERFLOW AFTER MPY INSTRUCTION *
847
848 VAR
849 locskip : integer ;
850
851 BEGIN
852 $OPTIONS compile = trace $
853 IF stattrace > none THEN
854 BEGIN
855 write mpcogout '@@@ DEBUT GENCHECKMULTOVER @@@' ;
856 nextline
857 END ;
858 $OPTIONS compile = true $
859 genstand pr6 evareaw istaq tn ;
860 genstand pr6 evareaw + 1 ilda tn ;
861 genstand nreg 36 ilrs tn ;
862 genstand pr6 evareaw icmpaq tn ;
863 locskip := indfich ;
864 genstand nreg 0 itze tic ;
865 genstand pr6 evareaw ildaq tn ;
866 genexceptcode mlterrcode raq ;
867 inser cb locskip ;
868 genstand nreg 0 iorq tdl ;
869 $OPTIONS compile = trace $
870 IF stattrace > none THEN
871 BEGIN
872 write mpcogout '@@@ FIN GENCHECKMULTOVER @@@' ;
873 nextline
874 END ;
875 $OPTIONS compile = true $
876 END * GENCHECKMULTOVER * ;
877
878
879 $OPTIONS page $
880
881 * ************************************ CHECKBNDS ***************************** *
882
883 PROCEDURE checkbnds errcode : integer ; freg : register ; fctp : ctp ;
884
885 * C .GENERATES THE CODE TO VERIFY IF THE VALUE IN FREG IS IN THE CLOSED
886 INTERVAL GIVEN BY THE BOUNDS OF THE TYPE "FCTP".
887 .IF ERROR CALL GENEXCEPTCODE
888 C *
889 VAR
890 lmin, lmax, locskip, locexit : integer ;
891 linst : istand ;
892 BEGIN * CHECKBNDS *
893 $OPTIONS compile = trace $
894 IF stattrace > none THEN
895 BEGIN
896 write mpcogout '@@@ DEBUT CHECKBNDS @@@ WITH CODEFREG FCTP AT' errcode : 4
897 regname freg : 9 ord fctp ;
898 nextline ;
899 END ;
900 $OPTIONS compile = true $
901 IF fctp # intptr THEN
902 BEGIN * ONLY FOR TYPE # INTEGER *
903 findminmax fctp lmin lmax ;
904 IF freg = ra THEN linst := icmpa ELSE linst := icmpq ;
905 gencstecode lmin linst ;
906 locskip := indfich ; genstand nreg 0 itmi tic ; * SKIP IF ERROR *
907 gencstecode lmax linst ;
908 locexit := indfich ; genstand nreg 0 itmoz tic ; * SKIP IF OK *
909 inser cb locskip ;
910 genexceptcode errcode freg ;
911 inser cb locexit ;
912 END * TYPE NOT INTEGER * ;
913 $OPTIONS compile = trace $
914 IF stattrace > low THEN
915 BEGIN
916 write mpcogout '@@@ FIN CHECKBNDS @@@' ; nextline ;
917 END ;
918 $OPTIONS compile = true $
919 END * CHECKBNDS * ;
920
921
922 $OPTIONS page $
923
924 * ************************************ FCT. INBOUNDS ************************* *
925
926 FUNCTION inbounds fval fmin fmax : integer : boolean ;
927
928 * C RETURNED VALUE IS TRUE IF FVAL IS THE CLOSED INTERVAL
929 FMIN..FMAX
930 FALSE OTHERWISE
931 C *
932 * E ERRORS DETECTED
933 406 : FMIN EXPECTED TO BE < FMAX
934 E *
935 BEGIN * INBOUNDS *
936 $OPTIONS compile = security $
937 IF fmin > fmax THEN error 406 ;
938 $OPTIONS compile = true $
939 IF fval < fmin THEN
940 inbounds := false ELSE
941 IF fval > fmax THEN
942 inbounds := false ELSE
943 inbounds := true ;
944 END * INBOUNDS * ;
945
946
947 $OPTIONS page $
948
949 * ************************************************ clearpsr ******** *
950
951 PROCEDURE clearpsr ;
952 BEGIN
953 mfari1 := a0r0i0 ; mfari2 := a1r0i0 ;
954 geneism imlr 0 p0t0r0 ;
955 gendesca nreg 0 0 l9 0 tn ;
956 gendesca pr6 psrdepw 0 l9 bytesforset tn ;
957 END ;
958
959
960 $OPTIONS page $
961
962 * ************************************ FUNCTION OLDNEWSTOR ******************* *
963
964 FUNCTION oldnewstor incrinbytes : integer : integer ;
965
966 * C THIS FCT. RETURNS THE OLD VALUE REALIGNED OF TEMPSTOR;
967 INCREMENTS TEMPSTOR FOR FUTURE USE;
968 READJUST TMAX IF NECESSARY
969 C *
970 BEGIN * OLDNEWSTOR *
971 $OPTIONS compile = trace $
972 IF stattrace > low THEN
973 BEGIN
974 write mpcogout '@@@ DEBUT-FIN OLDNEWSTOR @@@ WITH TEMPSTORTMAX INCREMENT'
975 tempstor tmax incrinbytes ;
976 nextline ;
977 END ;
978 $OPTIONS compile = true $
979 incrinbytes := recadre incrinbytes bytesinword ;
980 IF incrinbytes > bytesinword THEN
981 tempstor := recadre tempstor bytesindword ;
982 * <====== *
983 oldnewstor := tempstor ;
984 tempstor := tempstor + incrinbytes ;
985 IF tempstor > tmax THEN tmax := tempstor ;
986 END * OLDNEWSTOR * ;
987
988
989 $OPTIONS page $
990
991 * ************************************ NEWBLOC ******************************* *
992
993 PROCEDURE newbloc freg : register ;
994
995 * C .CREATES A NEW REGISTER BLOC ASSOCIATED WITH "FREG"
996 .RETURNS -CURRENTBLOC
997 -REGCHARGEFREG
998 C *
999 * E ERRORS DETECTED
1000 254 : EXPRESSION TOO COMPLICATED
1001 E *
1002 VAR
1003 lcurbloc : regpt ;
1004 BEGIN * NEWBLOC *
1005 $OPTIONS compile = trace $
1006 IF stattrace > none THEN
1007 BEGIN
1008 write mpcogout '@@@ DEBUT NEWBLOC @@@ WITH FREG' regname freg ; nextline ;
1009 END ;
1010 $OPTIONS compile = true $
1011 IF begfreelist = NIL THEN error 254 ELSE
1012 BEGIN
1013 lcurbloc := begfreelist ;
1014 begfreelist := begfreelist@.nextbloc ;
1015 WITH lcurbloc@ DO
1016 BEGIN
1017 sregister := freg ; saveplace := 0 ; nextbloc := currentbloc ; predbloc := NIL ;
1018 END ;
1019 forgetbox := forgetbox + 1 ;
1020 currentbloc@.predbloc := lcurbloc ;
1021 currentbloc := lcurbloc ;
1022 END ;
1023 regcharge freg := true ;
1024 $OPTIONS compile = trace $
1025 IF stattrace > low THEN
1026 BEGIN
1027 write mpcogout '* BOX CREATED AT @' ord currentbloc ' PREVIOUS WAS AT @'
1028 ord currentbloc@.nextbloc ;
1029 nextline ;
1030 write mpcogout '@@@ FIN NEWBLOC @@@' ; nextline ;
1031 END ;
1032 $OPTIONS compile = true $
1033 END * NEWBLOC * ;
1034
1035
1036 $OPTIONS page $
1037
1038 * ************************************ FREEBLOC ****************************** *
1039
1040 PROCEDURE freebloc VAR fbtofree : regpt ;
1041
1042 * C .IN ORDER TO HAVE A SHORT CHAIN OF USED REGISTERS THIS PROCEDURE "DELINKS"
1043 A BOXEACH TIME IT IS POSSIBLE.
1044 .FBTOFREE CAN BE NIL ==> NO OPERATION
1045 .IF ASSOCIATED REGISTER IS NOT SAVED THEN FREES IT.
1046 .MODIFY CURRENTBLOC FOR LAST CREATED BOX
1047 .FBTOFREE IS "NIL" AFTER EXCEPT FOR CURRENTBLOC
1048 C *
1049 * E ERRORS DETECTED
1050 417 FREEBLOC CALLED WITH DUMMYBLOC
1051 435 REGISTER NOT SAVED AND NOT FLAGGED "LOADED"
1052 E *
1053 VAR
1054 savecurbloc : regpt ;
1055 BEGIN * FREEBLOC *
1056 $OPTIONS compile = trace $
1057 IF stattrace > none THEN
1058 BEGIN
1059 write mpcogout '@@@ DEBUT -FIN DE FREEBLOC @@@' ; nextline ;
1060 IF stattrace = high THEN
1061 BEGIN
1062 write mpcogout '* THE FOLLOWING BOX HAS BEEN FREED:' ; nextline ;
1063 printregbox fbtofree ;
1064 END ;
1065 END ;
1066 $OPTIONS compile = true $
1067 $OPTIONS compile = security $
1068 IF fbtofree = dummybloc THEN error 417 ELSE
1069 $OPTIONS compile = true $
1070 IF fbtofree # NIL THEN
1071 WITH fbtofree@ DO
1072 BEGIN
1073 IF predbloc = NIL THEN
1074 BEGIN
1075 savecurbloc := nextbloc ; nextbloc@.predbloc := NIL ;
1076 END ELSE
1077 BEGIN
1078 predbloc@.nextbloc := nextbloc ; nextbloc@.predbloc := predbloc ;
1079 savecurbloc := currentbloc ;
1080 END ;
1081 IF saveplace = 0 THEN
1082 $OPTIONS cc = secuity + $
1083 IF NOT regcharge sregister THEN error 435 ELSE
1084 $OPTIONS cc = secuity - $
1085 regcharge sregister := false ;
1086 forgetbox := forgetbox - 1 ;
1087 fbtofree@.nextbloc := begfreelist ;
1088 begfreelist := fbtofree ;
1089 fbtofree := NIL ;
1090 currentbloc := savecurbloc ;
1091 END * WITH#NIL * ;
1092 END * FREEBLOC * ;
1093
1094
1095 $OPTIONS page $
1096
1097 PROCEDURE sauvereg freg : register ; fload : boolean ; FORWARD ;
1098
1099 * *********************** STACK_EXTENSION ************************* *
1100
1101 PROCEDURE stack_extension ;
1102
1103 * THIS PROCEDUREIS CALLED FOR DYNAMIC STACK EXTENSIONS *
1104
1105 * GENERATED CODE ASSUMES THAT RQ CONTAINS NUMBER OF WORDS *
1106 * PR5 MODIFIED BY pascal_operators_ MUST BE SAVED IF USED *
1107
1108 BEGIN
1109 IF NOT stack_has_been_extended THEN
1110 BEGIN
1111 stack_has_been_extended := true ;
1112 saved_stack_end_place := oldnewstor bytesindword DIV bytesinword ;
1113 genstand pr6 next_sp_place iepp3 tny ;
1114 genstand pr6 saved_stack_end_place ispri3 tn ;
1115 END ;
1116 sauvereg pr5 false ;
1117 genstand pr0 extend_stack_op_place itsp3 tn ;
1118 END ;
1119
1120 $OPTIONS page $
1121
1122 * ************************************ FREEALLREGISTERS ********************** *
1123
1124 PROCEDURE freeallregisters ;
1125
1126 * C .FOR EACH STATEMENT'S BEGINNING ALL REGISTERS ARE FREE
1127 .ALL THE CREATED BOXES ARE REMOVED
1128 .THE WORKING STORAGE IS FREED
1129 * LCSAVE = MEMORIZED AVAILABLE STORAGE IN CURRENT FRAME BYTES
1130 * TEMPSTOR = CURRENT AVAILABLE STORAGE IN CURRENT FRAME BYTES
1131 * DUMMYBLOC IS CREATED IN ENTERBODY FOR ALL THE PROCEDURE
1132 C *
1133 * E ERRORS DETECTED
1134 429 SOME REGISTER BOX NOT FREED
1135 E *
1136 VAR
1137 it : integer ;
1138 BEGIN * FREEALLREGISTERS *
1139 $OPTIONS compile = trace $
1140 IF stattrace > none THEN
1141 BEGIN
1142 write mpcogout '@@@ DEBUT FREEALLREGISTERS @@@ WITH LCSAVETEMPSTOR:' lcsave
1143 tempstor ;
1144 nextline ;
1145 END ;
1146 IF forgetbox # 0 THEN
1147 IF errtotal = 0 THEN
1148 BEGIN
1149 error 429 ;
1150 write mpcogout '******** FORGETBOX IS :' forgetbox ; nextline ;
1151 END ;
1152 $OPTIONS compile = true $
1153 FOR it := forgetbox DOWNTO 1 DO
1154 freebloc currentbloc ; * FREE FORGET BOXES *
1155 regcharge := freereg ;
1156 workformaths := false ;
1157 IF stack_has_been_extended THEN
1158 BEGIN
1159 stack_has_been_extended := false ;
1160 genstand pr6 saved_stack_end_place iepp1 tny ;
1161 genstand pr0 reset_stack_end_op_place itsp3 tn ;
1162 END ;
1163 tempstor := lcsave ;
1164 forgetbox := 0 ;
1165 currentbloc := dummybloc ;
1166 $OPTIONS compile = trace $
1167 IF stattrace > low THEN
1168 BEGIN
1169 write mpcogout '@@@ FIN FREEALLREGISTERS @@@ ' ; nextline ;
1170 END ;
1171 $OPTIONS compile = true $
1172 END * FREEALLREGISTERS * ;
1173
1174 $OPTIONS page $
1175
1176
1177 * ************************************ FCT RAISUSED ************************* *
1178
1179 FUNCTION raisused : boolean ;
1180
1181 * TRUE IF A-REGISTER IS USED MAY BE AAQEAQ *
1182 BEGIN * RAISUSED *
1183 raisused := true ;
1184 IF NOT regcharge ra THEN
1185 IF NOT regcharge raq THEN
1186 IF NOT regcharge reaq THEN
1187 raisused := false ;
1188 END * RAISUSED * ;
1189
1190 $OPTIONS page $
1191
1192
1193 * ************************************ FCT. RQISUSED ************************ *
1194
1195 FUNCTION rqisused : boolean ;
1196
1197 * TRUE IF Q-REGISTER IS USED MAY BE QAQEAQ *
1198 BEGIN * RQISUSED *
1199 rqisused := true ;
1200 IF NOT regcharge rq THEN
1201 IF NOT regcharge raq THEN
1202 IF NOT regcharge reaq THEN
1203 rqisused := false ;
1204 END * RQISUSED * ;
1205
1206
1207 $OPTIONS page $
1208
1209 * ************************************ FCT. RAQISUSED ************************ *
1210
1211 FUNCTION raqisused : boolean ;
1212
1213 * TRUE IF AQ-REGISTER IS USED MAY BE AQAQ *
1214 * USED EAQ RAQ AND REAQ *
1215 BEGIN * RAQISUSED *
1216 raqisused := true ;
1217 IF NOT regcharge ra THEN
1218 IF NOT regcharge rq THEN
1219 IF NOT regcharge raq THEN
1220 IF NOT regcharge reaq THEN
1221 raqisused := false ;
1222 END * RAQISUSED * ;
1223
1224
1225
1226 $OPTIONS page $
1227
1228 * ************************************ SAUVEREG ****************************** *
1229 PROCEDURE sauvereg ;
1230
1231 * C .THIS PROCEDURE MUST BE CALLED EACH TIME THE CONTENT OF A REGISTER
1232 WILL BE ALTERED
1233 .IF FREG ALREADY USED THEN SAVE IT AND MEMORIZES SAVING PLACE IN
1234 ASSOCIATED BOX
1235 .THE USED REGISTERS ARE CHAINED FROM CURRENTBLOC UNTIL DUMMYBLOC.
1236 .IF "FLOAD" THEN CREATES A NEW BOX AND FLAG IT LOADED
1237 ELSE SAVE IT
1238 .SPECIAL CASES
1239 FREG=RA THEN CHECK AQ EAQ
1240 =RQ CHECK AQ EAQ
1241 =AQ CHECK A Q EAQ
1242 =EAQ CHECK A Q EAQ
1243 C *
1244 * E ERRORS DETECTED
1245 403: BOX NOT FOUND
1246 404: REGISTER ALREADY SAVED
1247 E *
1248 LABEL
1249 1 ; * EXIT WHILE *
1250 VAR
1251 lreg lregq auxreg auxregq : register ;
1252 lcurrbloc : regpt ;
1253 linst : istand ;
1254 lincr : integer ;
1255 BEGIN * SAUVEREG *
1256 $OPTIONS compile = trace $
1257 IF stattrace > none THEN
1258 BEGIN
1259 write mpcogout '@@@ DEBUT SAUVEREG @@@ WITH FREGFLOAD:' regname freg fload ;
1260 nextline ;
1261 IF stattrace = high THEN printstatusregister ;
1262 END ;
1263 $OPTIONS compile = true $
1264 lreg := nreg ; * DEFAULT MEANS THERE IS NO REGISTER TO SAVE *
1265 lregq := nreg ;
1266 IF regcharge freg THEN
1267 lreg := freg ELSE
1268 BEGIN * SPECIAL FOR ACC-QUOT *
1269 IF freg >= ra THEN
1270 IF freg <= reaq THEN
1271 BEGIN
1272 IF regcharge reaq THEN lreg := reaq ELSE
1273 IF regcharge raq THEN lreg := raq ELSE
1274 IF freg >= raq THEN
1275 BEGIN
1276 IF regcharge ra THEN lreg := ra ;
1277 IF regcharge rq THEN
1278 IF lreg = nreg THEN lreg := rq ELSE lregq := rq ;
1279 END * >=RAQ * ;
1280 END * RA..REAQ * ;
1281 END * SPECIAL * ;
1282 IF lreg # nreg THEN
1283 BEGIN
1284 * AT LEAST ONE TO SAVE *
1285 * FIND ASSOCIATED BOXES *
1286 lcurrbloc := currentbloc ;
1287 auxreg := lreg ; auxregq := lregq ;
1288 WHILE lcurrbloc # NIL DO
1289 WITH lcurrbloc@ DO
1290 BEGIN
1291 IF sregister = auxreg THEN
1292 BEGIN
1293 $OPTIONS compile = trace $
1294 IF saveplace # 0 THEN error 404 ;
1295 $OPTIONS compile = true $
1296 lincr := bytesinword ; * COMMON DEFAULT *
1297 CASE lreg OF
1298 pr1 pr2 pr5 pr7 : BEGIN linst := prinst spri lreg ;
1299 lincr := bytesindword ;
1300 END ;
1301 x0 x1 x2 x3 x4 x5 : linst := xinst sxl lreg ;
1302 ra : linst := ista ;
1303 rq : linst := istq ;
1304 raq : BEGIN linst := istaq ; lincr := bytesindword ;
1305 END * RAQ * ;
1306 reaq : BEGIN linst := idfst ; lincr := bytesindword ;
1307 END * REAQ * ;
1308 psr : BEGIN linst := inop ; lincr := psrinbytes ;
1309 END * PSR * ;
1310 END * CASE LREG * ;
1311 saveplace := oldnewstor lincr ;
1312 * SAVING INSTR. NOW *
1313 IF linst # inop THEN
1314 genstand pr6 saveplace DIV bytesinword linst tn ELSE
1315 BEGIN * MOVE PSR *
1316 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1317 geneism imlr 0 * FILL BYTE * p0t0r0 ;
1318 gendesca pr6 psrdepw 0 l9 psrinbytes tn ; * ORIGIN *
1319 gendesca pr6 saveplace DIV bytesinword 0 l9 psrinbytes tn ;
1320 END * MOVE PSR * ;
1321 IF auxregq = nreg THEN GOTO 1 ; * EXIT WHILE *
1322 auxreg := nreg ;
1323 END * SREGISTER = AUXREG * ELSE
1324 IF sregister = auxregq THEN
1325 BEGIN
1326 $OPTIONS compile = security $
1327 IF saveplace # 0 THEN error 404 ;
1328 $OPTIONS compile = true $
1329 saveplace := oldnewstor bytesinword ;
1330 genstand pr6 saveplace DIV bytesinword istq tn ;
1331 regcharge rq := false ;
1332 IF auxreg = nreg THEN GOTO 1 ; * EXIT WHILE *
1333 auxregq := nreg ;
1334 END * LREGQ * ;
1335 lcurrbloc := nextbloc ;
1336 END * WITHWHILE * ;
1337 * EXIT HERE MEANS COMPILER'S ERROR *
1338 error 403 ;
1339 1 :
1340 IF lreg # freg THEN
1341 regcharge lreg := false ;
1342 END * A REGISTER TO SAVE * ;
1343 IF fload THEN
1344 newbloc freg ELSE regcharge freg := false ;
1345 $OPTIONS compile = trace $
1346 IF stattrace > low THEN
1347 BEGIN
1348 write mpcogout '* SAVED REGISTERS ISARE:' regname lreg regname lregq ;
1349 nextline ;
1350 write mpcogout '@@@ FIN SAUVEREG @@@' ; nextline ;
1351 END ;
1352 $OPTIONS compile = true $
1353 END * SAUVEREG * ;
1354
1355
1356 $OPTIONS page $
1357
1358 * ************************************ REGENERE ****************************** *
1359
1360 PROCEDURE regenere oldbloc : regpt ;
1361
1362 * C .OLDBLOC NOT NIL POINTS A REGISTER BOX WHOSE SREGISTER MUST BE
1363 RELOADED IF NOT ALREADY LOADED FOR THIS BLOC
1364 .IF PREVIOUS LOADED IT IS SAVED
1365 .REGCHARGE MUST BE TRUE AFTER
1366 C *
1367 * E ERRORS DETECTED
1368 427: OLDBLOC IS NIL
1369 428: REG NOT SAVEDNOT LOADED
1370 E *
1371 VAR
1372 ltag : tag ;
1373 linst : istand ;
1374 BEGIN * REGENERE *
1375 $OPTIONS compile = trace $
1376 IF stattrace > none THEN
1377 BEGIN
1378 write mpcogout '@@@ DEBUT REGENERE @@@' ; nextline ;
1379 IF stattrace = high THEN
1380 BEGIN
1381 printstatusregister ;
1382 printregbox oldbloc ;
1383 END ;
1384 END ;
1385 $OPTIONS compile = true $
1386 $OPTIONS compile = security $
1387 IF oldbloc = NIL THEN error 427 ELSE
1388 IF oldbloc@.saveplace = 0 AND
1389 NOT regcharge oldbloc@.sregister THEN error 428 ELSE
1390 $OPTIONS compile = true $
1391 WITH oldbloc@ DO
1392 IF saveplace # 0 THEN
1393 BEGIN * SAVED * ltag := tn ;
1394 sauvereg sregister false ;
1395 CASE sregister OF
1396 pr1 pr2 pr5 pr7 :
1397 BEGIN ltag := tny ; linst := prinst epp sregister ; END ;
1398 x0 x1 x2 x3 x4 x5 x6 x7 : linst := xinst lxl sregister ;
1399 ra : linst := ilda ;
1400 rq : linst := ildq ;
1401 raq : linst := ildaq ;
1402 reaq : linst := idfld ;
1403 psr : linst := inop ;
1404 END * CASE SREGISTER * ;
1405 IF linst # inop THEN
1406 genstand pr6 saveplace DIV bytesinword linst ltag ELSE
1407 BEGIN * RELOAD PSR *
1408 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1409 geneism imlr 0 * FILL BYTE * p0t0r0 ;
1410 gendesca pr6 saveplace DIV bytesinword 0 l9 psrinbytes tn ;
1411 gendesca pr6 psrdepw 0 l9 psrinbytes tn ;
1412 psrsize := psrinbytes ;
1413 END * RELOAD PSR * ;
1414 saveplace := 0 ;
1415 regcharge sregister := true ;
1416 END * REG WAS SAVED * ;
1417 $OPTIONS compile = trace $
1418 IF stattrace > low THEN
1419 BEGIN
1420 write mpcogout '@@@ FIN REGENERE @@@' ; nextline ;
1421 END ;
1422 $OPTIONS compile = true $
1423 END * REGENERE * ;
1424
1425
1426 $OPTIONS page $
1427
1428 * ************************************ GETPR ********************************* *
1429
1430 PROCEDURE getpr ;
1431
1432 * C .A NEW POINTER REGISTER IS REQUESTED
1433 .SEARCHS A FREE IN PR1..MAXPRUSED
1434 IF NONE SAVE ONE THE LAST
1435 .BY CALLING SAUVEREG
1436 CREATES A NEW BOX POINTED BY CURRENTBLOC REGCHARGE TRUE
1437 .RETURNS CURRENTPR
1438 C *
1439 LABEL
1440 1 ; * EXIT LOOP FOR *
1441 VAR
1442 lpr : preg ;
1443 BEGIN * GETPR *
1444 $OPTIONS compile = trace $
1445 IF stattrace > none THEN
1446 BEGIN
1447 write mpcogout '@@@ DEBUT GETPR @@@' ; nextline ;
1448 END ;
1449 $OPTIONS compile = true $
1450 FOR lpr := pr1 TO maxprused DO
1451 IF NOT regcharge lpr THEN
1452 GOTO 1 ; * EXIT LOOP WITH LPR OK *
1453 * HERE ALL PRI'S ALREADY LOADED. *
1454 * LPR BECOMES MAXPRUSED *
1455 lpr := maxprused ;
1456 1 :
1457 sauvereg lpr true ; * CURRENTBLOC REGCHARGE OK *
1458 currentpr := lpr ;
1459 $OPTIONS compile = trace $
1460 IF stattrace > low THEN
1461 BEGIN
1462 write mpcogout '@@@ FIN GETPR @@@ WITH CURRENTPR:' regname currentpr ; nextline ;
1463 END ;
1464 $OPTIONS compile = true $
1465 END * GETPR * ;
1466
1467
1468 $OPTIONS page $
1469
1470 * ************************************ GETINDEX ****************************** *
1471
1472 PROCEDURE getindex ;
1473
1474 * C .A NEW INDEX REGISTER IS REQUESTED.
1475 .SEARCHES A FREE ONE IN X0..MAXINXUSED
1476 IF NONESAVE ONE ALWAYS THE LAST
1477 .BY CALLING SAUVEREG
1478 CREATES A NEW BLOC REGCHARGE OK
1479 .RETURNS CURRENTINDEX
1480 C *
1481 LABEL
1482 1 ; * EXIT FOR *
1483 VAR
1484 linx : register ;
1485 BEGIN * GETINDEX *
1486 $OPTIONS compile = trace $
1487 IF stattrace > none THEN
1488 BEGIN write mpcogout '@@@ DEBUT GETINDEX @@@' ; nextline ;
1489 END ;
1490 $OPTIONS compile = true $
1491 FOR linx := x0 TO maxinxused DO
1492 IF NOT regcharge linx THEN
1493 GOTO 1 ; * EXIT LOOP WITH LINX OK *
1494 * HERE ALL XI'S ALREADY LOADED. *
1495 * SELECT MAXINXUSED *
1496 linx := maxinxused ;
1497 1 :
1498 sauvereg linx true ; * CURRENTBLOC REGCHARGE OK *
1499 currentindex := linx ;
1500 $OPTIONS compile = trace $
1501 IF stattrace > low THEN
1502 BEGIN
1503 write mpcogout '@@@ FIN GETINDEX @@@ WITH CURRENTINDEX:' regname currentindex ;
1504 nextline ;
1505 END ;
1506 $OPTIONS compile = true $
1507 END * GETINDEX * ;
1508
1509
1510 $OPTIONS page $
1511
1512 * ************************** LOADBASE **************************************** *
1513
1514 PROCEDURE loadbase flev : integer ;
1515
1516 * C
1517 THIS PROCEDURE LOADS A POINTER REGISTER WITH THE BASIS OF THE STACK FRAME
1518 OF THE PROCEDURE DEFINED AT THE LEVEL "FLEV" ;
1519 IN EACH FRAME AT DISPLACEMENT DLKDEP THERE IS AN ITS PAIR POINTING THE
1520 FRAME OF THE LOGICAL MOTHER-PROCEDURE PREPARED BY CALLING SEQUENCE
1521 STORED BY ENTRY SEQUENCE
1522 C *
1523 VAR
1524 it : integer ;
1525 linst : istand ;
1526 BEGIN * LOADBASE *
1527 $OPTIONS compile = trace $
1528 IF stattrace > none THEN
1529 BEGIN
1530 write mpcogout '@@@ DEBUT LOADBASE @@@ WITH FLEV' flev : 4 ; nextline ;
1531 END ;
1532 $OPTIONS compile = true $
1533 * OBTAINS A FREE PR IN "CURRENTPR" *
1534 getpr ; * CURRENTBLOC ASSIGNED HERE *
1535 linst := prinst epp currentpr ;
1536 genstand pr6 dlkdepw linst tny ; * LOGICAL MOTHER *
1537 FOR it := 1 TO level - flev - 1 DO
1538 genstand currentpr dlkdepw linst tny ;
1539 $OPTIONS compile = trace $
1540 IF stattrace > low THEN
1541 BEGIN
1542 write mpcogout '@@@ FIN LOADBASE @@@ WITH CURRENTPR: ' regname currentpr
1543 ' CURRENTBLOC AT @ ' ord currentbloc ' LEVEL IS:' level : 4 ;
1544 nextline ;
1545 END ;
1546 $OPTIONS compile = true $
1547 END * LOADBASE * ;
1548
1549
1550 $OPTIONS page $
1551
1552 * ************************************ ADDRESSVAR **************************** *
1553
1554 PROCEDURE addressvar fctp : ctp ; VAR fattr : attr ; modif : boolean ;
1555
1556 * C ."FCTP" IS A NOT NIL POINTER ON A CONTEXTTABLE BOX
1557 * VARS PROC FIELD
1558 .WITH BOX'S INFORMATIONSBUILDS A "VARBL"FATTR.USED TO ADDRESS POINTED ITEM
1559 . ONE FIELD OF FCTP@ CAN BE ALTERED .VISUSED
1560 C *
1561 * E ERRORS DETECTED
1562 438 FCTP IS NIL
1563 E *
1564 VAR
1565 it : integer ;
1566
1567 BEGIN * ADDRESSVAR *
1568 $OPTIONS compile = trace $
1569 IF stattrace > none THEN
1570 BEGIN
1571 write mpcogout '@@@ DEBUT ADDRESSVAR @@@ WITH FCTP AT @' ord fctp ; nextline ;
1572 END ;
1573 IF fctp = NIL THEN error 438 ELSE
1574 $OPTIONS compile = true $
1575 WITH fctp@ * POINTED BOX * fattr * BUILT ATTR * DO
1576 BEGIN
1577 * COMMON FIELDS *
1578 initattrvarbl fattr ;
1579 nameaddr := ctptr ;
1580 * NOW THREE MAJOR CASES VARS-FIELD-PROC *
1581 IF klass = vars THEN
1582 BEGIN
1583 typtr := vtype ; vlev := vlevel ;
1584 pckd := false ;
1585 IF vtype # NIL THEN
1586 IF vtype@.form = power THEN pckd := vtype@.pack ;
1587 visused := true ; * FOR FCTP@ *
1588 IF vtype = NIL THEN
1589 BEGIN
1590 dplmt := 0 ; itsdplmt := 0 ; basebloc := NIL ; basereg := pr6 ; vlev := level ;
1591 END ELSE
1592 IF vkind = actual THEN
1593 IF vtype^.form = files THEN
1594 BEGIN
1595 itsdplmt := 0 ; dplmt := 0 ;
1596 IF vlev = 0 THEN
1597 BEGIN
1598 basereg := prstatic ; basebloc := NIL ; access := pointable ;
1599 itsdplmt := vaddr ;
1600 END ELSE
1601 IF vlev = level THEN
1602 BEGIN
1603 basereg := pr6 ; basebloc := NIL ; access := pointable ;
1604 itsdplmt := vaddr ;
1605 END ELSE
1606 BEGIN
1607 loadbase vlev ;
1608 basereg := currentpr ; basebloc := currentbloc ; access := pointable ;
1609 itsdplmt := vaddr ;
1610 END ;
1611 END ELSE
1612 BEGIN
1613 itsdplmt := 0 ; dplmt := vaddr ;
1614 IF vlev = 0 THEN
1615 BEGIN * GLOBAL *
1616 basereg := prstatic ; basebloc := NIL ; access := direct ;
1617 END * GLOBAL * ELSE
1618 IF vlev = level THEN
1619 BEGIN * LOCAL *
1620 basereg := pr6 ; basebloc := NIL ; access := direct ;
1621 END * LOCAL * ELSE
1622 BEGIN * INTERM. *
1623 loadbase vlev ; * RETURNS CURRENTPRCURRENTBLOC *
1624 basereg := currentpr ; basebloc := currentbloc ; access := pointee ;
1625 END * INTERM. * ;
1626 END * ACTUAL * ELSE
1627 IF vkind = formal THEN
1628 BEGIN
1629 itsdplmt := vaddr ; dplmt := 0 ; access := pointable ;
1630 IF vlev = level THEN
1631 BEGIN * LOCAL PARM *
1632 basereg := pr6 ; basebloc := NIL ;
1633 END * LOCAL * ELSE
1634 BEGIN * INTERM. *
1635 loadbase vlev ; * RETURNS CURRENTPRCURRENTBLOC *
1636 basereg := currentpr ; basebloc := currentbloc ;
1637 END * INTERM. * ;
1638 END * FORMAL * ELSE
1639 IF vkind = arraybound THEN
1640 BEGIN
1641 itsdplmt := vaddr ;
1642 dplmt := vdispl ; access := pointable ;
1643 IF vlev = level THEN
1644 BEGIN
1645 basereg := pr6 ; basebloc := NIL
1646 END ELSE
1647 BEGIN
1648 loadbase vlev ;
1649 basereg := currentpr ; basebloc := currentbloc
1650 END ;
1651 END * ARRAYBOUND * ELSE
1652 BEGIN * IMPORTEDEXPORTABLE *
1653 basereg := prlink ; basebloc := NIL ; dplmt := 0 ; access := pointable ;
1654 itsdplmt := vaddr ;
1655 END * EXTERNAL * ;
1656 END * KLASS=VARS * ELSE
1657 IF klass = field THEN * FOUND UNDER A WITH *
1658 * RECORD POINTED BY DISPLAYDISX *
1659 BEGIN
1660 typtr := fldtype ; basebloc := NIL ;
1661 WITH display disx DO
1662 IF occur = cwith THEN * NOT PACKED EASY TO ADDRESS *
1663 BEGIN
1664 vlev := clevel ; pckd := false ; itsdplmt := 0 ;
1665 IF vlev = 0 THEN basereg := prstatic ELSE basereg := pr6 ;
1666 dplmt := cdspl + fldaddr ; access := direct ;
1667 IF symbolmap THEN
1668 FOR it := 1 TO creflist.nbr DO
1669 IF modif THEN nameisref creflist.symbolp it symbolfile -symbolline
1670 ELSE nameisref creflist.symbolp it symbolfile symbolline ;
1671 END * CWITH * ELSE
1672 BEGIN * VWITH *
1673 * VDSPL IS AN POINTER *
1674 * STORED BY WITHSTAT *
1675 vlev := level ; itsdplmt := vdspl ; basereg := pr6 ;
1676 dplmt := fldaddr ; access := pointable ;
1677 IF typtr@.form <= scalar THEN
1678 pckd := bytwidth < bytesinword ELSE pckd := vpack OR typtr@.pack ;
1679 IF symbolmap THEN
1680 FOR it := 1 TO vreflist.nbr DO
1681 IF modif THEN nameisref vreflist.symbolp it symbolfile -symbolline
1682 ELSE nameisref vreflist.symbolp it symbolfile symbolline ;
1683 END * VWITH WITH DISPLAY * ;
1684 END * FIELD * ELSE
1685 BEGIN * KLASS = PROC *
1686 * FOR A FUNCTION ASSIGNMENT *
1687 typtr := proctype ; pckd := false ; itsdplmt := 0 ;
1688 vlev := proclevel + 1 ;
1689 IF vlev = level THEN
1690 BEGIN
1691 access := direct ; basereg := pr6 ; basebloc := NIL ;
1692 END ELSE
1693 BEGIN
1694 loadbase vlev ;
1695 access := pointee ; basereg := currentpr ; basebloc := currentbloc ;
1696 END ;
1697 dplmt := fctdepl ;
1698 * USE OF RESERVED WORDS *
1699 * IN CURRENT STACK FRAME *
1700 END * PROC * ;
1701 END * WITH FCTP@FATTR * ;
1702 $OPTIONS compile = trace $
1703 IF stattrace > low THEN
1704 BEGIN
1705 IF stattrace = high AND fctp # NIL THEN
1706 printattr fattr ;
1707 write mpcogout '@@@ FIN ADDRESSVAR @@@' ; nextline ;
1708 END ;
1709 $OPTIONS compile = true $
1710 END * ADDRESSVAR * ;
1711
1712
1713 $OPTIONS page $
1714
1715 * ************************************ CALCVARIENT *************************** *
1716
1717 PROCEDURE calcvarient VAR fattr : attr ; VAR fbase : preg ; VAR fdisp : integer ;
1718 VAR ftag : tag ;
1719
1720 * C GIVEN A FATTR IF LVAL THEN CHANGED HERE
1721 TYPTR # NIL
1722 KIND= VARBL OR SVAL NOT POWER OR SAVED LVAL
1723 THIS PROCEDURE RETURNS THREE ITEMS NEEDED TO ADDRESS THE "WORD"
1724 FBASE
1725 FDISP EXPRESSED IN WORDS
1726 FTAG
1727 FOR SVAL INSTRUCTION MUST BE GENERATE AFTER CALL
1728 C *
1729 * E ERRORS DETECTED
1730 412 TYPTR IS NIL
1731 413 KIND=LVAL NOT SAVED
1732 414 KIND=CHAIN OR LCOND
1733 E *
1734 VAR
1735 locdepw locmemw : integer ;
1736 wretpt : wcstpt ;
1737 rretpt : rcstpt ;
1738 lretpt : lcstpt ;
1739 llretpt : llcstpt ;
1740 linst : istand ;
1741 $OPTIONS compile = true $
1742 $OPTIONS compile = security $
1743 ltag : tag ;
1744 BEGIN * CALCVARIENT *
1745 $OPTIONS compile = trace $
1746 IF stattrace > none THEN
1747 BEGIN
1748 write mpcogout '@@@ DEBUT CALCVARIENT @@@' ; nextline ;
1749 IF stattrace = high THEN
1750 printattr fattr ;
1751 END ;
1752 IF fattr.typtr = NIL THEN error 412 ELSE
1753 $OPTIONS compile = true $
1754 fbase := nreg ; fdisp := 0 ; ftag := tn ;
1755 IF fattr.kind = lval THEN
1756 lvalvarbl fattr ;
1757 WITH fattr DO
1758 IF kind = varbl THEN
1759 BEGIN
1760 IF basereg <= maxprused THEN
1761 regenere basebloc ;
1762 IF inxreg # nxreg THEN
1763 IF inxbloc@.saveplace # 0 THEN
1764 BEGIN
1765 IF NOT rqisused THEN inxreg := rq ELSE
1766 IF NOT raisused THEN inxreg := ra ELSE inxreg := x6 ;
1767 inxbloc@.sregister := inxreg ;
1768 regenere inxbloc ;
1769 END * MODIFIER SAVED * ;
1770 locdepw := dplmt DIV bytesinword ;
1771 locmemw := inxmem DIV bytesinword ;
1772 fbase := basereg ; * <=== *
1773 IF access = pointable THEN
1774 BEGIN
1775 fdisp := itsdplmt DIV bytesinword ; * <=== *
1776 IF fdisp >= twoto14 OR fdisp < -twoto14 THEN
1777 BEGIN
1778 genstand nreg fdisp ieax7 tn ;
1779 freebloc basebloc ; getpr ;
1780 genstand basereg 0 prinst epp currentpr tx7 ;
1781 fdisp := 0 ; basebloc := currentbloc ; basereg := currentpr ;
1782 END ;
1783 IF inxreg = nxreg THEN
1784 BEGIN
1785 IF locmemw = 0 THEN
1786 BEGIN * NO STORAGE MODIFIER *
1787 IF locdepw = 0 THEN
1788 ftag := tny ELSE
1789 BEGIN
1790 genstand nreg locdepw ieax7 tn ; ftag := tyx7 ;
1791 END * LOCDEPW#0 * ;
1792 END * LOCMEMW=0 * ELSE
1793 BEGIN * LOCMEMW#0 *
1794 genstand pr6 locmemw ilxl7 tn ;
1795 IF locdepw # 0 THEN
1796 genstand nreg locdepw iadlx7 tdu ;
1797 ftag := tyx7 ;
1798 END * LOCMEMW #0 * ;
1799 END * INXREG=NXREG * ELSE
1800 BEGIN * INXREG =RA RQ XI *
1801 IF locdepw # 0 THEN
1802 BEGIN
1803 IF inxreg = rq THEN
1804 BEGIN
1805 linst := iadq ; ltag := tdl ;
1806 END * RQ * ELSE
1807 IF inxreg = ra THEN
1808 BEGIN
1809 linst := iada ; ltag := tdl ;
1810 END * RA * ELSE
1811 BEGIN * XI *
1812 linst := xinst adlx inxreg ; ltag := tdu ;
1813 END * XI * ;
1814 genstand nreg locdepw linst ltag ;
1815 END * LOCDEPW * ;
1816 IF locmemw # 0 THEN
1817 BEGIN * STORAGE MODIFIER *
1818 IF inxreg = rq THEN
1819 linst := iadq ELSE
1820 IF inxreg = ra THEN
1821 linst := iada ELSE
1822 linst := ilxl7 ;
1823 genstand pr6 locmemw linst tn ;
1824 IF linst = ilxl7 THEN
1825 BEGIN * CUMUL WITH PREVIOUS INXREG *
1826 genstand pr6 evareaw istx7 tn ; * STORE IN 0..17 *
1827 genstand pr6 evareaw xinst adlx inxreg tn ;
1828 END * ILXL7 * ;
1829 END * LOCMEMW# 0 * ;
1830 * <=== *
1831 ftag := starmodif inxreg ;
1832 END * INXREG RA RQ XI * ;
1833 END * ACCESS POINTABLE * ELSE
1834 BEGIN * POINTEEDIRECT *
1835 * <=== *
1836 fdisp := locdepw ;
1837 IF fdisp >= twoto14 OR fdisp < -twoto14 THEN
1838 BEGIN
1839 IF inxreg = nxreg THEN
1840 BEGIN
1841 genstand nreg fdisp ieax7 tn ;
1842 inxreg := x7 ;
1843 END
1844 ELSE
1845 BEGIN
1846 IF inxreg = rq THEN linst := iadq
1847 ELSE IF inxreg = ra THEN linst := iada
1848 ELSE linst := xinst adlx inxreg ;
1849 genstand nreg fdisp linst tdl ;
1850 END ;
1851 fdisp := 0 ;
1852 END ;
1853 IF inxreg = nxreg THEN
1854 BEGIN
1855 IF locmemw = 0 THEN
1856 ftag := tn ELSE
1857 BEGIN
1858 genstand pr6 locmemw ilxl7 tn ; ftag := tx7 ;
1859 END * LOCMEM#0 * ;
1860 END * NXREG * ELSE
1861 BEGIN * # NXREG *
1862 IF locmemw # 0 THEN
1863 BEGIN * CUMUL *
1864 IF inxreg = rq THEN
1865 linst := iadq ELSE
1866 IF inxreg = ra THEN
1867 linst := iada ELSE linst := ilxl7 ;
1868 genstand pr6 locmemw linst tn ;
1869 IF linst = ilxl7 THEN
1870 BEGIN
1871 genstand pr6 evareaw istx7 tn ;
1872 genstand pr6 evareaw xinst adlx inxreg tn ;
1873 END * ILXL7 * ;
1874 END * CUMUL * ;
1875 * <==== *
1876 ftag := modif inxreg ;
1877 END * # NXREG * ;
1878 END * POINTEEDIRECT * ;
1879 freebloc basebloc ;
1880 freebloc inxbloc ;
1881 END * KIND=VARBL * ELSE
1882 IF kind = sval THEN
1883 BEGIN * <=== * fbase := nreg ; fdisp := 0 ; ftag := tic ;
1884 IF typtr@.form = power THEN
1885 BEGIN
1886 IF longv = bytesindword THEN
1887 BEGIN
1888 enterlcst valpw lretpt ; enterundlab lretpt@.lplace ;
1889 END ELSE
1890 BEGIN
1891 enterllcst valpw llretpt ; enterundlab llretpt@.llplace ;
1892 END ;
1893 END ELSE
1894 IF typtr = nilptr THEN
1895 BEGIN
1896 enterlcst nilpseudoset lretpt ;
1897 enterundlab lretpt@.lplace ;
1898 END * NIL * ELSE
1899 IF typtr = realptr THEN
1900 BEGIN
1901 enterreal rsval rretpt ;
1902 enterundlab rretpt@.rplace ;
1903 END * REAL * ELSE
1904 IF inbounds val 0 twoto17m1 THEN
1905 BEGIN
1906 * <=== * fdisp := val ; ftag := tdl ;
1907 END ELSE
1908 BEGIN
1909 entercst val wretpt ;
1910 enterundlab wretpt@.cstplace ;
1911 END ;
1912 END * SVAL *
1913 $OPTIONS compile = trace $
1914 ELSE
1915 IF kind = lval THEN error 413 ELSE error 414
1916 $OPTIONS compile = true $
1917 ;
1918 * END WITH FATTR *
1919 $OPTIONS compile = trace $
1920 IF stattrace > low THEN
1921 BEGIN
1922 write mpcogout '@@@ FIN CALCVARIENT @@@ WITH FBASEFDISPFTAG: ' regname fbase
1923 fdisp : 12 tagsymb ftag : 5 ;
1924 nextline ;
1925 END ;
1926 $OPTIONS compile = true $
1927 END * CALCVARIENT * ;
1928
1929
1930 $OPTIONS page $
1931
1932 * ************************************ LOADADR ******************************* *
1933
1934 PROCEDURE loadadr VAR fattr : attr ; wantedpr : preg ;
1935
1936 * C ."FATTR" DESCRIBES A VARBL OR A CHAIN
1937 .THIS PROC LOADS A PR. WITH THE COMPLETE ADDRESS OF ITEM
1938 .IF WANTEDPR = NREG THEN RETURNS CURRENTBLOC CURRENTPR
1939 ELSE LOADS ONLY WANTEDPR WITHOUT SAVING ANYTHING
1940 .FREES BASEBLOC INXBLOC
1941 C *
1942 * E ERRORS DETECTED
1943 405: FATTR MUST BE CHAIN OR VARBL
1944 E *
1945 VAR
1946 linst : istand ;
1947 ended : boolean ;
1948 prtoload lbase : preg ;
1949 locdep : integer ;
1950 BEGIN * LOADADR *
1951 $OPTIONS compile = trace $
1952 IF stattrace > none THEN
1953 BEGIN
1954 write mpcogout '@@@ DEBUT LOADADR @@@ WITH WANTEDPR ' regname wantedpr ;
1955 nextline ;
1956 IF stattrace = high THEN
1957 printattr fattr ;
1958 END ;
1959 $OPTIONS compile = true $
1960 lbase := nreg ;
1961 WITH fattr DO
1962 IF kind = varbl THEN
1963 BEGIN
1964 IF wantedpr = nreg THEN
1965 BEGIN
1966 IF basebloc = NIL THEN * BASEREG PR4 OR PR6 *
1967 BEGIN
1968 getpr ;
1969 lbase := basereg ; prtoload := currentpr ;
1970 END * NIL * ELSE
1971 BEGIN
1972 IF basebloc@.saveplace = 0 THEN
1973 BEGIN
1974 freebloc basebloc ; newbloc basereg ;
1975 currentpr := basereg ;
1976 lbase := basereg ; prtoload := basereg ;
1977 END ELSE
1978 BEGIN * SAVED *
1979 getpr ;
1980 genstand pr6 basebloc@.saveplace DIV bytesinword
1981 prinst epp currentpr tny ;
1982 lbase := currentpr ; prtoload := currentpr ;
1983 freebloc basebloc ;
1984 END * SAVED * ;
1985 END * # PR4PR6 * ;
1986 END * WANTEDPR=NREG * ELSE
1987 BEGIN
1988 prtoload := wantedpr ;
1989 IF basebloc = NIL THEN
1990 lbase := basereg ELSE
1991 IF basebloc@.saveplace = 0 THEN
1992 BEGIN
1993 freebloc basebloc ; lbase := basereg ;
1994 END ELSE
1995 BEGIN
1996 genstand pr6 basebloc@.saveplace DIV bytesinword
1997 prinst epp wantedpr tny ;
1998 lbase := wantedpr ; freebloc basebloc ;
1999 END ;
2000 END * WANTEDPR #NREG * ;
2001 IF access = pointable THEN
2002 BEGIN
2003 locdep := itsdplmt DIV bytesinword ;
2004 IF locdep >= twoto14 OR locdep < -twoto14 THEN
2005 BEGIN
2006 genstand nreg locdep ieax7 tn ;
2007 genstand lbase 0 prinst epp prtoload tx7y ;
2008 END
2009 ELSE
2010 genstand lbase locdep prinst epp prtoload tny ;
2011 access := pointee ;
2012 lbase := prtoload ;
2013 * BASEREG BASEBLOCITSDPLMT *
2014 * NO MORE MEANINGS FULL *
2015 END ;
2016 IF inxreg # nxreg THEN
2017 BEGIN
2018 IF inxbloc@.saveplace # 0 THEN
2019 BEGIN
2020 IF NOT raisused THEN inxreg := ra ELSE
2021 IF NOT rqisused THEN inxreg := rq ELSE inxreg := x6 ;
2022 inxbloc@.sregister := inxreg ;
2023 regenere inxbloc ;
2024 END ;
2025 END ;
2026 IF inxmem # 0 THEN
2027 BEGIN
2028 IF inxreg = ra THEN
2029 linst := iada ELSE
2030 IF inxreg = rq THEN
2031 linst := iadq ELSE
2032 IF inxreg = nxreg THEN
2033 BEGIN
2034 inxreg := x7 ; linst := ilxl7 ;
2035 END ELSE
2036 linst := inop ;
2037 IF linst # inop THEN
2038 BEGIN
2039 genstand pr6 inxmem DIV bytesinword linst tn ;
2040 inxmem := 0 ;
2041 END ;
2042 END ;
2043 ended := false ;
2044 IF prtoload = lbase THEN
2045 IF dplmt = 0 THEN
2046 IF inxreg = nxreg THEN
2047 ended := true ;
2048 IF NOT ended THEN
2049 BEGIN
2050 locdep := dplmt DIV bytesinword ;
2051 IF dplmt MOD bytesinword <> 0 THEN
2052 IF dplmt < 0 THEN
2053 locdep := locdep - 1 ;
2054 IF locdep >= twoto14 OR locdep < -twoto14 THEN
2055 BEGIN
2056 IF inxreg = ra THEN
2057 IF locdep > 0 THEN
2058 genstand nreg locdep iada tdl
2059 ELSE
2060 genstand nreg -locdep isba tdl
2061 ELSE IF inxreg = rq THEN
2062 IF locdep > 0 THEN
2063 genstand nreg locdep iadq tdl
2064 ELSE
2065 genstand nreg -locdep isbq tdl
2066 ELSE IF inxreg IN x0..x7 THEN
2067 genstand nreg locdep xinst adlx inxreg tdu
2068 ELSE
2069 BEGIN
2070 inxreg := x6 ;
2071 genstand nreg locdep ieax6 tn
2072 END ;
2073 locdep := 0 ;
2074 END ;
2075 genstand lbase locdep prinst epp prtoload
2076 modif inxreg ;
2077 IF inxmem # 0 THEN
2078 BEGIN
2079 genstand pr6 inxmem DIV bytesinword ilxl7 tn ;
2080 genstand prtoload 0 iawd tx7 ;
2081 END ;
2082 IF dplmt MOD bytesinword # 0 THEN * ALWAYS >= 0 *
2083 BEGIN
2084 genstand nreg dplmt MOD bytesinword ieax7 tn ;
2085 genstand prtoload 0 ia9bd tx7 ;
2086 END ;
2087 END ;
2088 freebloc inxbloc ; inxreg := nxreg ;
2089 END * KIND=VARBL * ELSE
2090 IF kind = chain THEN
2091 BEGIN
2092 IF wantedpr = nreg THEN
2093 BEGIN
2094 getpr ;
2095 prtoload := currentpr ;
2096 END ELSE
2097 prtoload := wantedpr ;
2098 * ALFACTP POINTS A BOX *
2099 * KONSTALFACONST *
2100 enterundlab alfactp@.unddeb ;
2101 genstand nreg 0 prinst epp prtoload tic ;
2102 END * CHAIN * ELSE
2103 error 405 ;
2104 $OPTIONS compile = trace $
2105 IF stattrace > low THEN
2106 BEGIN
2107 write mpcogout '@@@ FIN LOADADR @@@ WITH LOCALES PRTOLOADLBASE' regname prtoload
2108 regname lbase ; nextline ;
2109 END ;
2110 $OPTIONS compile = true $
2111 END * LOADADR * ;
2112
2113
2114 $OPTIONS page $
2115
2116 * ************************************ TRANSFER ****************************** *
2117
2118 PROCEDURE transfer VAR fattr : attr ; inwhat : destination ;
2119
2120 * C INWHAT . <== INACCINQINPSR FATTR BECOMES LVAL
2121 . ==> OUT GATTRLVAL ==> FATTR
2122 . INPR FATTR BECOMES POINTEE
2123 SUMMARY: LOADS A REGISTER WITH AN EXPRESSION DESCRIBED BY FATTR
2124 OR STORE ACC INTO THE VARBL DESCRIBED BY FATTR.
2125 C *
2126 * E ERRORS DETECTED
2127 400 LDREGBLOC = NIL
2128 401 LCOND SAVED
2129 416 LVAL SAVED
2130 418 INCORRECT ORIGIN
2131 420 FATTR.KIND # VARBL OUT
2132 421 GATTR.KIND # LVAL OUT
2133 E *
2134 VAR
2135 lretpt : lcstpt ;
2136 llretpt : llcstpt ;
2137 target : register ;
2138 loadinst lshift rshift rlogshift storinst llshift : istand ;
2139 lbase : preg ;
2140 ldisp rightcount leftcount longitem longset longmove : integer ;
2141 ltag : tag ;
2142 tomove callcalc
2143 $OPTIONS compile = security $ noterr
2144 $OPTIONS compile = true $
2145 : boolean ;
2146 lmove : ieism ;
2147
2148
2149 * ************************************ GENLOCSKIP < TRANSFER ***************** *
2150
2151 PROCEDURE genlocskip fjump : istand ;
2152
2153 * C GENERATES A BOOLEAN USING THE SETTING OF INDICATORS
2154 GENERATES FJUMP TO E1
2155 LOAD FALSE
2156 SKIP INCOND TO E2
2157 E1 LOAD TRUE
2158 E2
2159 C *
2160 VAR
2161 locskip1 locskip2 : integer ;
2162 BEGIN * GENLOCSKIP *
2163 locskip1 := indfich ; genstand nreg 0 fjump tic ;
2164 genstand nreg ord false loadinst tdl ;
2165 locskip2 := indfich ; genstand nreg 0 itra tic ;
2166 inser cb locskip1 ; genstand nreg ord true loadinst tdl ;
2167 inser cb locskip2 ;
2168 END * GENLOCSKIP * ;
2169
2170 BEGIN * TRANSFER *
2171 $OPTIONS compile = security $
2172 IF stattrace > none THEN
2173 BEGIN
2174 write mpcogout '@@@ DEBUT TRANSFER @@@ WITH INWHAT' ord inwhat ; nextline ;
2175 IF stattrace >= medium THEN
2176 BEGIN
2177 write mpcogout '* FATTR INPUT OF TRANSFER IS:' ; nextline ;
2178 printattr fattr ;
2179 END ;
2180 END ;
2181 $OPTIONS compile = true $
2182 WITH fattr DO
2183 IF typtr # NIL THEN
2184 IF typtr@.form # power THEN
2185 BEGIN * NOT A SET *
2186 IF inwhat # out THEN
2187 BEGIN
2188
2189 * LOAD SEQUENCE OF ITEM DESCRIBED BY FATTR *
2190 * FIRST FIND THE TARGET REGISTER AND SUITABLE LOAD INSTR. *
2191 * INACC ==> REAQ DFLD FOR REAL
2192 RAQ LDAQ FOR POINTER
2193 RA LDA OR LLS
2194 INQ ==> RQ LDQ FOR SMALL ITEMS OR SHIFT FROM RA
2195 INAQ ==> RAQ LDAQ *
2196 $OPTIONS compile = security $
2197 noterr := true ;
2198 $OPTIONS compile = true $
2199 CASE inwhat OF
2200 inaq :
2201 BEGIN
2202 $OPTIONS compile = security $
2203 noterr := kind = varbl AND typtr@.size = bytesindword AND
2204 typtr # realptr OR
2205 kind = lval AND ldreg = raq ;
2206 $OPTIONS compile = true $
2207 loadinst := ildaq ; target := raq ;
2208 END * INAQ * ;
2209 inq :
2210 BEGIN
2211 $OPTIONS compile = security $
2212 noterr := kind = varbl AND typtr@.size <= bytesinword OR
2213 kind = lval AND ldreg IN ra rq OR
2214 kind = sval AND typtr@.size <= bytesinword OR
2215 kind = lcond ;
2216 $OPTIONS compile = true $
2217 loadinst := ildq ; target := rq ;
2218 END * INQ * ;
2219 inacc :
2220 BEGIN
2221 IF typtr = realptr THEN
2222 BEGIN loadinst := idfld ; target := reaq ;
2223 END * REAL * ELSE
2224 IF typtr@.size = bytesindword OR typtr@.form = pointer THEN
2225 BEGIN
2226 target := raq ; * ENDING TARGET *
2227 * ALSO FOR PACKED POINTER *
2228 IF pckd AND kind = varbl AND typtr@.form = pointer THEN
2229 loadinst := ilprp3 ELSE loadinst := ildaq ;
2230 END * BYTESINDWORD * ELSE
2231 BEGIN
2232 target := ra ; loadinst := ilda ;
2233 END ;
2234 END * INACC * ;
2235 inpr :
2236 $OPTIONS compile = security $
2237 noterr := kind = varbl ;
2238 $OPTIONS compile = true $
2239 END * CASE INWHAT * ;
2240 $OPTIONS compile = security $
2241 IF NOT noterr THEN error 418 ELSE
2242 $OPTIONS compile = true $
2243 CASE kind OF
2244 varbl :
2245 BEGIN
2246 callcalc := true ;
2247 IF pckd THEN
2248 IF typtr@.form # pointer THEN
2249 BEGIN
2250 callcalc := false ;
2251 loadadr fattr nreg ;
2252 vlev := level ;
2253 itsdplmt := 0 ;
2254 access := pointee ;
2255 basereg := currentpr ;
2256 basebloc := currentbloc ;
2257 dplmt := 0 ;
2258 inxreg := nxreg ;
2259 inxbloc := NIL ;
2260 inxmem := 0 ;
2261 inxmemrw := true ;
2262 pckd := true ;
2263 END ;
2264 IF callcalc THEN
2265 calcvarient fattr lbase ldisp ltag ;
2266 IF inwhat = inpr THEN
2267 BEGIN
2268 getpr ; * ==> CURRENTPRCURRENTBLOC REGCHARGE *
2269 IF pckd THEN * PACKED POINTER ON ONE WORD *
2270 BEGIN
2271 usednameaddr := nameaddr ;
2272 genstand lbase ldisp prinst lprp currentpr ltag END ELSE
2273 BEGIN * NOT PACKED *
2274 IF ltag <= tx7 * NO INDIRECT MODIFIER * THEN
2275 BEGIN
2276 usednameaddr := nameaddr ;
2277 genstand lbase ldisp prinst epp currentpr
2278 newtagstar ltag
2279 * TAG BECOMES TAG* * END ELSE
2280 BEGIN * ALREADY INDIRECT *
2281 genstand lbase ldisp prinst epp currentpr ltag ;
2282 usednameaddr := nameaddr ;
2283 genstand currentpr 0 prinst epp currentpr tny ;
2284 END ;
2285 END * NOT PACKED * ;
2286 * FATTR BECOMES POINTEE *
2287 vlev := level ; itsdplmt := 0 ;
2288 access := pointee ; basereg := currentpr ;
2289 basebloc := currentbloc ; dplmt := 0 ;
2290 inxreg := nxreg ; inxbloc := NIL ; inxmem := 0 ;
2291 inxmemrw := true ; pckd := false ;
2292 END * INPR * ELSE
2293 BEGIN
2294 IF callcalc THEN
2295 BEGIN
2296 sauvereg target true ; * CURRENTBLOC REGCHARGE OK *
2297 usednameaddr := nameaddr ;
2298 genstand lbase ldisp loadinst ltag ;
2299 END ;
2300 * FOR PACKED ITEMS *
2301 * THE WHOLE WORD IS LOADED *
2302 IF pckd THEN
2303 IF typtr@.form = pointer THEN
2304 BEGIN
2305 genstand pr6 evareaw ispri3 tn ;
2306 genstand pr6 evareaw ildaq tn ;
2307 END ELSE
2308 BEGIN * PCKD NOT POINTER *
2309 IF callcalc THEN
2310 BEGIN
2311 rightcount
2312 := bitsinword - bitsinbyte * packedsize typtr ;
2313 leftcount := dplmt MOD bytesinword * bitsinbyte ;
2314 IF target = ra THEN
2315 BEGIN
2316 lshift := ials ; rshift := iars ; rlogshift := iarl ;
2317 END * RA * ELSE
2318 BEGIN * RQ *
2319 lshift := iqls ; rshift := iqrs ; rlogshift := iqrl ;
2320 END * RQ * ;
2321 IF leftcount # 0 THEN
2322 genstand nreg leftcount lshift tn ;
2323 IF typtr@.form = numeric THEN
2324 genstand nreg rightcount rshift tn ELSE
2325 genstand nreg rightcount rlogshift tn ;
2326 END ELSE
2327 BEGIN
2328 * BASEREG POINTS ITEM *
2329 longitem := packedsize typtr ;
2330 IF typtr@.form = scalar THEN
2331 BEGIN
2332 lmove := imrl ; longmove := bytesinword ;
2333 rightcount := 0 ;
2334 END ELSE
2335 BEGIN
2336 lmove := imlr ; longmove := longitem ;
2337 rightcount := bytesinword - longitem * bitsinbyte ;
2338 END ;
2339 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
2340 geneism lmove 0 * FILL 0 * p0t0r0 ;
2341 usednameaddr := nameaddr ;
2342 gendesca basereg 0 0 l9 longitem tn ;
2343 gendesca pr6 evareaw 0 l9 longmove tn ;
2344 IF basebloc # NIL THEN freebloc basebloc ;
2345 sauvereg target true ;
2346 genstand pr6 evareaw loadinst tn ;
2347 IF rightcount # 0 THEN
2348 BEGIN
2349 IF target = rq THEN rshift := iqrs ELSE
2350 rshift := iars ;
2351 genstand nreg rightcount rshift tn ;
2352 END ;
2353 END ;
2354 END * PCKD NOT POINTER * ;
2355 * CHANGE NOW FATTR *
2356 kind := lval ; ldreg := target ; ldregbloc := currentbloc ;
2357 END * NOT INPR * ;
2358 END * VARBL * ;
2359 sval :
2360 BEGIN
2361 sauvereg target true ;
2362 calcvarient fattr lbase ldisp ltag ;
2363 genstand lbase ldisp loadinst ltag ;
2364 * CHANGE FATTR *
2365 kind := lval ; ldreg := target ; ldregbloc := currentbloc ;
2366 END * SVAL * ;
2367 lval : BEGIN
2368 $OPTIONS compile = security $
2369 IF ldregbloc@.saveplace # 0 THEN error 416 ;
2370 $OPTIONS compile = true $
2371 * NOOPERATION EXCEPT *
2372 * EXCHANGE BETWEEN RA<==> RQ *
2373 IF inwhat = inacc AND ldreg = rq THEN
2374 llshift := ills ELSE
2375 IF inwhat = inq AND ldreg = ra THEN
2376 llshift := ilrl ELSE
2377 llshift := inop ;
2378 IF llshift # inop THEN
2379 BEGIN
2380 sauvereg target true ;
2381 genstand nreg bitsinword llshift tn ;
2382 freebloc ldregbloc ;
2383 ldreg := target ; ldregbloc := currentbloc ;
2384 END ;
2385 END * LVAL * ;
2386 lcond :
2387 BEGIN
2388 IF accbloc = NIL THEN
2389 sauvereg target true ELSE
2390 IF target # accbloc@.sregister THEN
2391 BEGIN
2392 freebloc accbloc ; sauvereg target true ;
2393 END ELSE
2394 $OPTIONS compile = security $
2395 IF accbloc@.saveplace # 0 THEN error 401 ELSE
2396 $OPTIONS compile = true $
2397 BEGIN
2398 freebloc accbloc ; newbloc target ;
2399 END ;
2400 CASE transf OF
2401 1 : * BOOLEAN IS IN A0 *
2402 IF target = ra THEN
2403 genstand nreg bitsinword - 1 iarl tn ELSE
2404 genstand nreg bitsindword - 1 ilrl tn ;
2405 2 : * ZERO ON <==> TRUE *
2406 genlocskip itze ;
2407 3 : * BOOLEAN IS IN A *
2408 IF target = rq THEN
2409 genstand nreg bitsinword ilrl tn ;
2410 4 : * SVAL TRUE *
2411 genstand nreg ord true loadinst tdl ;
2412 5 : * SVAL FALSE *
2413 genstand nreg ord false loadinst tdl ;
2414 6 : * ZERO OFF TRUE *
2415 genlocskip itnz ;
2416 7 : * NEGATIVE ON TRUE *
2417 genlocskip itmi ;
2418 8 : * NEGATIVE OR ZERO ON TRUE *
2419 genlocskip itmoz ;
2420 9 : * NEGATIVE OFF TRUE *
2421 genlocskip itpl ;
2422 10 : * ZERO OFF AND NEGATIVE OFF TRUE *
2423 genlocskip itpnz ;
2424 11 : * CARRY OFF TRUE *
2425 genlocskip itnc ;
2426 12 : * CARRY ON TRUE *
2427 genlocskip itrc ;
2428 13 : * REVERSE BOOLEAN IN A *
2429 BEGIN
2430 genstand nreg 1 iera tdl ;
2431 IF target = rq THEN
2432 genstand nreg bitsinword ilrl tn ;
2433 END ;
2434 14 : * BOOLEAN IS IN Q *
2435 IF target = ra THEN
2436 genstand nreg bitsinword ills tn ;
2437 15 : * REVERSE BOOLEAN IS IN Q *
2438 BEGIN
2439 genstand nreg 1 ierq tdl ;
2440 IF target = ra THEN
2441 genstand nreg bitsinword ills tn ;
2442 END ;
2443 END * CASE TRANSF * ;
2444 * NOW CHANGES FATTR *
2445 kind := lval ; ldreg := target ; ldregbloc := currentbloc ;
2446 END * LCOND * ;
2447 END * CASE KIND * ;
2448 END * INWHAT # OUT * ELSE
2449 BEGIN * TRANSFER OUT *
2450 $OPTIONS compile = security $
2451 IF kind # varbl THEN error 420 ;
2452 IF gattr.kind # lval THEN error 421 ELSE
2453 $OPTIONS compile = true $
2454 regenere gattr.ldregbloc ;
2455 CASE gattr.ldreg OF
2456 reaq : storinst := idfst ;
2457 raq : storinst := istaq ;
2458 ra : storinst := ista ;
2459 rq : storinst := istq ;
2460 END * CASE GATTR.LDREG * ;
2461 IF NOT pckd OR typtr@.form = pointer * ONE ORTWOWORDS * THEN
2462 calcvarient fattr lbase ldisp ltag ELSE
2463 BEGIN
2464 loadadr fattr nreg ;
2465 lbase := currentpr ; ldisp := 0 ; ltag := tn ;
2466 freebloc currentbloc ;
2467 END ;
2468 IF NOT pckd THEN
2469 BEGIN
2470 usednameaddr := nameaddr ;
2471 genstand lbase ldisp storinst ltag END ELSE
2472 IF typtr@.form = pointer THEN
2473 BEGIN
2474 genstand pr6 evareaw istaq tn ;
2475 genstand pr6 evareaw iepp3 tny ;
2476 usednameaddr := nameaddr ;
2477 genstand lbase ldisp isprp3 ltag ;
2478 END * PCKD POINTER * ELSE
2479 BEGIN
2480 * MOVE INSTR *
2481 longitem := packedsize typtr ;
2482 genstand pr6 evareaw storinst tn ;
2483 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; * ONLY POINTER REG *
2484 geneism imlr 0 p0t0r0 ;
2485 gendesca pr6 evareaw bytesinword - longitem l9 longitem tn ;
2486 usednameaddr := nameaddr ;
2487 gendesca lbase 0 0 l9 longitem tn ;
2488 END * PCKD NOT POINTER * ;
2489 END * TRANSFER OUT * ;
2490 END * TRANSFER IN/OUT NOT FOR SET * ELSE
2491 BEGIN * SET *
2492 IF inwhat # out THEN
2493 BEGIN
2494
2495 * INWHAT=INACC LENGTH <=BYTESINDWORD ==> IN AQ EXCEPT LVAL
2496 > ==> IN PSR
2497 FATTR BECOMES LVAL
2498 *
2499 longset := typtr@.size * bitsinbyte ;
2500 IF kind = varbl THEN
2501 BEGIN
2502 IF longset > bitsindword THEN inwhat := inpsr ;
2503 END ELSE
2504 IF kind = sval THEN
2505 BEGIN
2506 IF inwhat <> inaq * Force * THEN
2507 IF longv > bytesindword OR
2508 longset > bitsindword THEN inwhat := inpsr ;
2509 END ;
2510 IF inwhat IN inacc inaq THEN
2511 BEGIN
2512 IF kind = varbl THEN
2513 BEGIN
2514 IF longset <= bitsinhword THEN
2515 BEGIN
2516 * MOVE SEQ *
2517 loadadr fattr pr3 ;
2518 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
2519 geneism icsl 3 * 0011=MOVE * p0t0r0 ; * FILL BIT=0 *
2520 usednameaddr := nameaddr ;
2521 gendescb pr3 0 0 0 longset tn ;
2522 gendescb pr6 evareaw 0 0 bitsindword tn ;
2523 * LOAD SEQUENCE *
2524 sauvereg raq true ;
2525 genstand pr6 evareaw ildaq tn ;
2526 END * <= BITSINHWORD * ELSE
2527 BEGIN
2528 calcvarient fattr lbase ldisp ltag ;
2529 sauvereg raq true ;
2530 IF longset = bitsinword THEN
2531 BEGIN * LOAD A CLEAR Q *
2532 usednameaddr := nameaddr ;
2533 genstand lbase ldisp ilda ltag ;
2534 genstand nreg 0 ildq tdl ;
2535 END ELSE
2536 BEGIN
2537 usednameaddr := nameaddr ;
2538 genstand lbase ldisp ildaq ltag ;
2539 END ;
2540 END * >BITSINHWORD * ;
2541 END * VARBL * ELSE
2542 IF kind = sval THEN
2543 BEGIN
2544 sauvereg raq true ;
2545 enterlcst valpw lretpt ;
2546 enterundlab lretpt@.lplace ;
2547 genstand nreg 0 ildaq tic ;
2548 END
2549 $OPTIONS compile = security $
2550 ELSE
2551 IF ldregbloc@.saveplace # 0 THEN error 416
2552 $OPTIONS compile = true $ ;
2553 IF kind # lval THEN
2554 BEGIN
2555 kind := lval ; ldreg := raq ; ldregbloc := currentbloc ;
2556 END ;
2557 END * INWHAT=INACC * ELSE
2558 BEGIN * INWHAT=INPSR *
2559 * INCLUDE LONG VARBL SVAL FOR INACC *
2560 IF kind = lval THEN
2561 BEGIN
2562 * AQ ==> PSR PSR NOOP *
2563 IF ldreg = raq THEN
2564 BEGIN
2565 sauvereg psr true ;
2566 regenere ldregbloc ; clearpsr ;
2567 genstand pr6 psrdepw istaq tn ;
2568 freebloc ldregbloc ;
2569 ldreg := psr ; psrsize := bytesindword ; ldregbloc := currentbloc ;
2570 END * RAQ *
2571 $OPTIONS compile = security $
2572 ELSE
2573 IF ldregbloc@.saveplace # 0 THEN error 416
2574 $OPTIONS compile = true $ ;
2575 END * LVAL * ELSE
2576 BEGIN * ALWAYS A MOVE *
2577 sauvereg psr true ;
2578 * BUILD ORIGIN *
2579 IF kind = varbl THEN
2580 loadadr fattr pr3 ELSE
2581 BEGIN * SVAL *
2582 IF longv = bytesindword THEN
2583 BEGIN
2584 enterlcst valpw lretpt ;
2585 enterundlab lretpt@.lplace ;
2586 END ELSE
2587 BEGIN * LONG SET *
2588 enterllcst valpw llretpt ;
2589 enterundlab llretpt@.llplace ;
2590 END ;
2591 genstand nreg 0 iepp3 tic ;
2592 longset := longv * bitsinbyte ;
2593 END * SVAL * ;
2594 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
2595 geneism icsl 3 * 0011=MOVE * p0t0r0 ; * FILL BIT=0 *
2596 IF kind = varbl THEN usednameaddr := nameaddr ;
2597 gendescb pr3 0 0 0 longset tn ;
2598 gendescb pr6 psrdepw 0 0 bitsforset tn ;
2599 kind := lval ; ldreg := psr ; ldregbloc := currentbloc ;
2600 psrsize := sup typtr@.size bytesindword ;
2601 END * ALWAYS A MOVE SVAL//VARBL * ;
2602 END * INPSR * ;
2603 END * INWHAT # OUT * ELSE
2604 BEGIN * OUT *
2605 tomove := true ; ldisp := 0 ;
2606 longset := typtr^.size * bitsinbyte ;
2607 longmove := longset ;
2608 $OPTIONS compile = security $
2609 IF gattr.kind # lval THEN error 421 ELSE
2610 IF gattr.ldregbloc = NIL THEN error 400 ELSE
2611 IF gattr.ldregbloc@.saveplace # 0 THEN error 416 ELSE
2612 $OPTIONS compile = true $
2613 IF gattr.ldreg = psr THEN
2614 ldisp := psrdepw ELSE
2615 IF typtr@.size = bytesindword THEN
2616 tomove := false ELSE
2617 BEGIN
2618 ldisp := evareaw ; genstand pr6 evareaw istaq tn ;
2619 IF longmove > bitsindword THEN
2620 longmove := bitsindword ;
2621 END ;
2622 IF tomove THEN
2623 BEGIN
2624 loadadr fattr pr3 ;
2625 mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
2626 geneism icsl 3 * 0011=MOVE * p0t0r0 ;
2627 gendescb pr6 ldisp 0 0 longmove tn ;
2628 IF kind = varbl THEN usednameaddr := nameaddr ;
2629 gendescb pr3 0 0 0 longset tn ;
2630 END * TOMOVE * ELSE
2631 BEGIN * STORE AQ *
2632 calcvarient fattr lbase ldisp ltag ;
2633 IF kind = varbl THEN usednameaddr := nameaddr ;
2634 genstand lbase ldisp istaq ltag ;
2635 END * NOT TO MOVE * ;
2636 END * TRANSFER OUT * ;
2637 END * SET * ;
2638 IF inwhat = out THEN freeattr gattr ;
2639 $OPTIONS compile = trace $
2640 IF stattrace > low THEN
2641 BEGIN
2642 write mpcogout '@@@ FIN TRANSFER @@@' ; nextline ;
2643 END ;
2644 $OPTIONS compile = true $
2645 END * TRANSFER * ;
2646
2647
2648
2649 $OPTIONS page $
2650
2651 * *************************************** CHOICERARQ *********************** *
2652
2653 PROCEDURE choicerarq ;
2654
2655 * C FOR GATTR LCONDVARBLSVAL CHOOSES THE SUITABLE TARGET RARQ
2656 THEN CALL TRANSFER INACC OR INQ
2657 C *
2658 * E ERRORS DETECTED
2659 422 : GATTR.KIND = CHAIN CHOICERARQ
2660 E *
2661 BEGIN * CHOICERARQ *
2662 $OPTIONS compile = trace $
2663 IF stattrace > none THEN
2664 BEGIN
2665 write mpcogout '@@@ DEBUT CHOICERARQ @@@' ; nextline ;
2666 END ;
2667 $OPTIONS compile = true $
2668 IF gattr.typtr # NIL THEN
2669 WITH gattr DO
2670 IF typtr@.form IN reel pointer THEN transfer gattr inacc ELSE
2671 CASE kind OF
2672 varbl sval : IF NOT rqisused THEN
2673 transfer gattr inq ELSE
2674 transfer gattr inacc ;
2675 lval : ;
2676 lcond : IF accbloc # NIL THEN
2677 BEGIN
2678 IF accbloc@.sregister = ra THEN
2679 transfer gattr inacc ELSE
2680 transfer gattr inq ;
2681 END * #NIL * ELSE
2682 transfer gattr inacc ;
2683 chain :
2684 $OPTIONS compile = security $
2685 error 422
2686 $OPTIONS compile = true $
2687 ;
2688 END * CASE KIND WITH GATTR * ;
2689 $OPTIONS compile = trace $
2690 IF stattrace > low THEN
2691 BEGIN
2692 write mpcogout '@@@ FIN CHOICERARQ @@@' ; nextline ;
2693 END ;
2694 $OPTIONS compile = true $
2695 END * CHOICERARQ * ;
2696
2697
2698
2699 $OPTIONS page $
2700
2701 * ************************************ VARIAB ******************************** *
2702
2703 PROCEDURE variab fvarset : boolean ;
2704
2705 * C PRECALL SEQUENCE FOR "VARIABLE"
2706 AN IDENTIFIER NO=1 IS EXPECTED
2707 MUST BE VARS OR FIELD
2708 FVARSET IS TRUE IF VARIABLE IS TO BE ALTERED
2709 C *
2710 * E ERRORS DETECTED
2711 2: IDENTIFIER EXPECTED
2712 103: IDENTIFIER FOUND IS NOT OF APPROPRIATE KLASS.
2713 104: IDENTIFIER NOT DECLARED
2714 196: VARIABLE IS READONLY
2715 E *
2716 BEGIN * VARIAB *
2717 $OPTIONS compile = trace $
2718 IF stattrace > none THEN
2719 BEGIN
2720 write mpcogout '@@@ DEBUT VARIAB @@@ WITH NOFVARSET' no : 4 fvarset : 6 ;
2721 nextline ;
2722 END ;
2723 $OPTIONS compile = true $
2724 variabctptr := NIL ;
2725 IF no # 1 * ID * THEN
2726 BEGIN
2727 error 2 ; gattr.typtr := NIL ;
2728 END ELSE
2729 BEGIN * ID *
2730 search ;
2731 IF ctptr = NIL THEN
2732 BEGIN * ID NOT FOUND *
2733 error 104 ;
2734 ctptr := undecptr ; * UNDECLARED VARIABLE *
2735 END ;
2736 IF ctptr@.klass <= proc THEN * NOT VARS-FIELD *
2737 BEGIN
2738 IF symbolmap THEN
2739 IF fvarset THEN nameisref ctptr symbolfile -symbolline
2740 ELSE nameisref ctptr symbolfile symbolline ;
2741 error 103 ; insymbol ; gattr.typtr := NIL ; * ERROR INDICATOR *
2742 END ELSE
2743 BEGIN * VARS-FIELD *
2744 IF ctptr@.klass = vars THEN
2745 BEGIN
2746 IF fvarset THEN
2747 BEGIN
2748 IF ctptr@.visreadonly THEN error 196 ;
2749 ctptr@.visset := true ;
2750 variabctptr := ctptr ;
2751 END ;
2752 END ;
2753 variable fvarset ;
2754 END * VARS- FIELD * ;
2755 END * ID * ;
2756 $OPTIONS compile = trace $
2757 IF stattrace > low THEN
2758 BEGIN
2759 write mpcogout '@@@ FIN VARIAB @@@ WITH NO' no : 4 ; nextline ;
2760 END ;
2761 $OPTIONS compile = true $
2762 END * VARIAB * ;
2763
2764
2765 $OPTIONS page $
2766
2767 BEGIN
2768 END.