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) change(86-09-11,JMAthane), approve(86-09-11,MCR7521),
  13      audit(86-09-15,JPFauche), install(86-11-12,MR12.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 CHECKBNDS(ARRAYS) *)
 210       asscheck : boolean ;                        (* SET IN INSYMBOL T+,A+ FOR ASSIGN CHECK *)
 211       cltransf : ARRAY [1..6] OF integer ;        (* GIVES THE TRANSF CORR. TO OPER.  8,CL *)
 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 A,Q,AQ,EAQ *)
 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  8,CL --> 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 FBOXPT,EXIT 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  (FVAL0,FVAL1) 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 FVAL0,FVAL1 :', 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 FUNDINX(OUT), 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 FARG,FINST', 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 CODE,FREG, 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 TEMPSTOR,TMAX, 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    -REGCHARGE[FREG]
 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 BOX,EACH 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 LCSAVE,TEMPSTOR:', 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 A,AQ,EAQ) *)
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 Q,AQ,EAQ) *)
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 A,Q,AQ, *)
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 FREG,FLOAD:', 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 BOX(ES) *)
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 (* WITH,WHILE *) ;
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 REGISTER(S) IS(ARE):', 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 SAVED,NOT 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 NONE,SAVE 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 INFORMATIONS,BUILDS 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 CURRENTPR,CURRENTBLOC *)
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 CURRENTPR,CURRENTBLOC *)
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                   (* IMPORTED,EXPORTABLE *)
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 DISPLAY[DISX] *)
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                             (* POINTEE,DIRECT *)
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 (* POINTEE,DIRECT *) ;
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 FBASE,FDISP,FTAG: ', 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 (* # PR4,PR6 *) ;
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, BASEBLOC,ITSDPLMT *)
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                                                   (* (KONST,ALFACONST) *)
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 PRTOLOAD,LBASE', 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 . <== INACC,INQ,INPSR     FATTR BECOMES  LVAL
2121    . ==> OUT                 GATTR(LVAL) ==> 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 ;           (* ==> CURRENTPR,CURRENTBLOC, 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 LCOND,VARBL,SVAL CHOOSES THE SUITABLE TARGET (RA,RQ)
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 NO,FVARSET', 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.