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 switch trace := true $
  19   PROGRAM standstat ;
  20     $IMPORT
  21                                                   (* IMPORTED PROCEDURES  *)
  22       'RACINE (pascal)' :
  23         error,
  24         inserundlab,
  25         insymbol,
  26         nameisref,
  27         nextline,
  28         recadre,
  29         search_in_condition_attributes,
  30         skip,
  31         statement_begins,
  32         statement_ends,
  33         sup ;
  34       'MODATTR (pascal) ' :
  35         convreal,
  36         freeattr,
  37         initattrvarbl,
  38         isstring,
  39         lvalvarbl,
  40         varissimple ;
  41       'CONTEXTTABLE (pascal) ' :
  42         checkminmax,
  43         compatbin,
  44         conformantdim,
  45         packedsize ;
  46       'MODVARIABLE (pascal) ' :
  47         init_desc_address,
  48         variable,
  49         passparams ;
  50       'GENERE (pascal)' :
  51         gendesca,
  52         gendescb,
  53         geneism,
  54         genstand,
  55         inser ;
  56       'EXPR (pascal)' :
  57         expression ;
  58       'UNIQUE (pascal)' :
  59         heaperror ;
  60       'GENOPER (pascal)' :
  61         genjump ;
  62       'PROCSTAT (pascal)' :
  63         argvstat,
  64         dateandtime,
  65         delete_string,
  66         getput,
  67         insapp,
  68         insert_string,
  69         mvcir,
  70         newir,
  71         pckunpck,
  72         readir,
  73         stopstat,
  74         writeir ;
  75       'STATE (pascal)' :
  76         addressvar,
  77         calcvarient,
  78         checkbnds,
  79         choicerarq,
  80         currwithlist,
  81         enterlcst,
  82         enterundlab,
  83         freeallregisters,
  84         freebloc,
  85         gencstecode,
  86         genexceptcode,
  87         loadadr,
  88         loadbase,
  89         newbloc,
  90         regenere,
  91         sauvereg,
  92         transfer,
  93         variab,
  94         withvariable ;
  95       'optimized_procedures (alm)' :
  96         search ;
  97                                                   (* IMPORTED VARIABLES *)
  98       'DECLARE (pascal)' :
  99         clabix,
 100         labtab,
 101         lab_pdl_top,
 102         lkc,
 103         pop_lab_pdl,
 104         push_lab_pdl ;
 105       'RACINE (pascal)' :
 106         aval,
 107         boolptr,
 108         charptr,
 109         cl,
 110         ctptr,
 111         currentnode,
 112         display,
 113         envstandard,
 114         errcl,
 115         exportablecode,
 116         intptr,
 117         ival,
 118         lamptr,
 119         level,
 120         mapswitch,
 121         mpcogout,
 122         no,
 123         realptr,
 124         statnbr,
 125         string_ptr,
 126         sttindex,
 127         symbolfile,
 128         symbolindex,
 129         symbolline,
 130         symbolmap,
 131         top,
 132         undecptr,
 133         usednames ;
 134       'GENERE (pascal)' :
 135         cb,
 136         ic,
 137         indfich,
 138         mfari1,
 139         mfari2,
 140         mfreg2,
 141         usednameaddr ;
 142       'STATE (pascal)' :
 143         asscheck,
 144         currentbloc,
 145         currentpr,
 146         gattr,
 147         inxcheck,
 148         lcsave,
 149         linktomain,
 150         linktomainplace,
 151         maxprused,
 152         maxinxused,
 153         modif,
 154         opaq,
 155         prinst,
 156         stattrace,
 157         tmax$
 158 
 159     $EXPORT
 160       compstat $
 161 
 162 
 163 
 164 $OPTIONS page $
 165 
 166 
 167 $INCLUDE 'CONSTTYPE' $
 168 
 169 $OPTIONS page $
 170 
 171     VAR
 172 
 173 (* REDEFINE IMPORTED VARIABLES     *)
 174 
 175 (* FROM DECLARE *)
 176 
 177       clabix : integer ;
 178       labtab : ARRAY [1..maxlabs] OF labdescr ;
 179       lab_pdl_top : lab_pdl_ptr ;
 180       lkc : integer ;
 181 
 182 (* FROM RACINE  *)
 183       mpcogout : text ;
 184       envstandard : stdkind ;
 185       display : ARRAY [0..displimit] OF recidscope ;
 186       mapswitch : boolean ;
 187       top : integer ;
 188       sttindex : integer ;
 189       symbolfile : integer ;
 190       symbolindex : integer ;
 191       symbolline : integer ;
 192       symbolmap : boolean ;
 193       usednames : typusednames ;
 194       aval : alfaid ;
 195       level : levrange ;
 196       cl : integer ;
 197       no : integer ;
 198       intptr : ctp ;
 199       lamptr : ctp ;
 200       undecptr : ctp ;
 201       realptr : ctp ;
 202       ctptr : ctp ;
 203       errcl : ARRAY [norange] OF typofsymb ;
 204       ival : integer ;
 205       boolptr : ctp ;
 206       charptr : ctp ;
 207       exportablecode : boolean ;
 208       currentnode : blocknodeptr ;
 209       statnbr : integer ;
 210       string_ptr : ctp ;
 211 
 212 
 213 (* FROM GENERE  *)
 214       ic : integer ;
 215       cb : integer ;
 216       indfich : integer ;
 217       mfari1 : zari ;
 218       mfari2 : zari ;
 219       mfreg2 : mreg ;
 220       usednameaddr : ctp ;
 221 
 222 
 223 (* FROM STATE   *)
 224       inxcheck : boolean ;
 225       asscheck : boolean ;
 226       gattr : attr ;
 227       currentbloc : regpt ;
 228       prinst : ARRAY [typepr, pr1..pr6] OF istand ; (* GIVES A PR INSTRUCTION *)
 229       tmax : integer ;
 230       linktomain : boolean ;
 231       linktomainplace : integer ;
 232       lcsave : integer ;
 233       stattrace : levtrace ;
 234       maxinxused : register ;
 235       maxprused : preg ;
 236       modif : ARRAY [nxreg..rq] OF tag ;
 237       opaq : ARRAY [typeofop, ra..reaq] OF istand ; (* GIVES INST. WITH A,Q,AQ,EAQ *)
 238       currentpr : preg ;
 239       withvariable : boolean ;
 240       currwithlist : withreflist ;
 241 
 242 
 243 
 244 (* **************    VARIABLES LOCALES    ************************* *)
 245 
 246       splitstat : ARRAY [norange] OF integer ;    (* USED TO SELECT THE GOOD STAT. *)
 247 
 248 
 249     $VALUE
 250 
 251       splitstat = (
 252         1, 2, 19 * 1, 3, 1, 4, 1, 1, 5, 1, 6,
 253         1, 7, 1, 8, 1, 1, 9, 12 * 1, 10, 1, 1,
 254         1, 1, 1, 1, 1, 1, 1) $
 255 
 256 
 257 $OPTIONS page $
 258 
 259 (* REDEFINE IMPORTED PROCEDURES    *)
 260 (* FROM GENERE  *)
 261     PROCEDURE genstand (fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag) ; EXTERNAL ;
 262     PROCEDURE geneism (fcode : ieism ; ffield : integer ; fbits : zptr) ; EXTERNAL ;
 263     PROCEDURE gendesca (fareg : preg ; fadr, fcn : integer ; fta : lgcar ;
 264       fn : integer ; frlgth : mreg) ; EXTERNAL ;
 265     PROCEDURE gendescb (fareg : preg ; fadr, fc, fb, fn : integer ; frlgth : mreg) ; EXTERNAL ;
 266     PROCEDURE inser (fcb : integer ; fplace : integer) ; EXTERNAL ;
 267 
 268 
 269 (* FROM RACINE  *)
 270     PROCEDURE error (errno : integer) ; EXTERNAL ;
 271     PROCEDURE insymbol ; EXTERNAL ;
 272     PROCEDURE search_in_condition_attributes ; EXTERNAL ;
 273     PROCEDURE skip (nosym : integer) ; EXTERNAL ;
 274     PROCEDURE nextline ; EXTERNAL ;
 275     PROCEDURE search ; EXTERNAL ;
 276     FUNCTION recadre (fnum, fmod : integer) : integer ; EXTERNAL ;
 277     PROCEDURE inserundlab (fcb, fdebchain : integer) ; EXTERNAL ;
 278     PROCEDURE nameisref (p : ctp ; f, l : integer) ; EXTERNAL ;
 279     PROCEDURE statement_begins (genp : boolean) ; EXTERNAL ;
 280     PROCEDURE statement_ends (sttlength : integer) ; EXTERNAL ;
 281     FUNCTION sup (fval1, fval2 : integer) : integer ; EXTERNAL ;
 282 
 283 (* FROM EXPR    *)
 284     PROCEDURE expression ; EXTERNAL ;
 285 
 286 (* FROM MODATTR   *)
 287     PROCEDURE freeattr (VAR fattr : attr) ; EXTERNAL ;
 288     PROCEDURE lvalvarbl (VAR fattr : attr) ; EXTERNAL ;
 289     PROCEDURE initattrvarbl (VAR fattr : attr) ; EXTERNAL ;
 290     FUNCTION isstring (VAR fattr : attr) : boolean ; EXTERNAL ;
 291     FUNCTION varissimple (VAR fattr : attr) : boolean ; EXTERNAL ;
 292     PROCEDURE convreal (VAR fattr : attr) ; EXTERNAL ;
 293 
 294 
 295 (* FROM CONTEXTTABLE *)
 296 
 297     PROCEDURE checkminmax (fvalu : integer ; fctp : ctp ; ferrnum : integer) ; EXTERNAL ;
 298     PROCEDURE compatbin (typleft, typright : ctp ; VAR fgeneric : ctp) ; EXTERNAL ;
 299     FUNCTION conformantdim (ff : ctp) : boolean ; EXTERNAL ;
 300     FUNCTION packedsize (fctp : ctp) : integer ; EXTERNAL ;
 301 
 302 (* FROM MODVARIABLE *)
 303 
 304     PROCEDURE init_desc_address (fctp : ctp ; VAR fattr : attr) ; EXTERNAL ;
 305     PROCEDURE variable (fvarset : boolean) ; EXTERNAL ;
 306     PROCEDURE passparams (fctplace : integer) ; EXTERNAL ;
 307 
 308 
 309 
 310 (* FROM UNIQUE *)
 311     PROCEDURE heaperror ; EXTERNAL ;
 312 
 313 (* FROM GENOPER  *)
 314     PROCEDURE genjump (VAR inserplace : integer ; jumpdisp : integer) ; EXTERNAL ;
 315                                                   (* FROM PROCSTAT *)
 316     PROCEDURE argvstat ; EXTERNAL ;
 317     PROCEDURE getput (fcode : integer) ; EXTERNAL ;
 318     PROCEDURE readir (fcode : integer) ; EXTERNAL ;
 319     PROCEDURE pckunpck (fcode : integer) ; EXTERNAL ;
 320     PROCEDURE writeir (fcode : integer) ; EXTERNAL ;
 321     PROCEDURE newir (fcode : integer) ; EXTERNAL ;
 322     PROCEDURE stopstat ; EXTERNAL ;
 323     PROCEDURE dateandtime (fcode : integer) ; EXTERNAL ;
 324     PROCEDURE delete_string ; EXTERNAL ;
 325     PROCEDURE insapp (fcode : integer) ; EXTERNAL ;
 326     PROCEDURE insert_string ; EXTERNAL ;
 327     PROCEDURE mvcir (fcode : integer) ; EXTERNAL ;
 328 
 329 (* FROM STATE   *)
 330     PROCEDURE addressvar (fctp : ctp ; VAR fattr : attr ; modif : boolean) ; EXTERNAL ;
 331     PROCEDURE choicerarq ; EXTERNAL ;
 332     PROCEDURE enterlcst (VAR fval : setarray ; VAR fboxpt : lcstpt) ; EXTERNAL ;
 333     PROCEDURE enterundlab (VAR fundinx : integer) ; EXTERNAL ;
 334     PROCEDURE transfer (VAR fattr : attr ; inwhat : destination) ; EXTERNAL ;
 335     PROCEDURE genexceptcode (ferrcode : integer ; freg : register) ; EXTERNAL ;
 336     PROCEDURE variab (fvarset : boolean) ; EXTERNAL ;
 337     PROCEDURE freebloc (VAR fbtofree : regpt) ; EXTERNAL ;
 338     PROCEDURE loadadr (VAR fattr : attr ; wantedpr : preg) ; EXTERNAL ;
 339     PROCEDURE calcvarient (VAR fattr : attr ; VAR fbase : preg ; VAR fdisp : integer ;
 340       VAR ftag : tag) ; EXTERNAL ;
 341     PROCEDURE gencstecode (farg : integer ; finst : istand) ; EXTERNAL ;
 342     PROCEDURE checkbnds (errcode : integer ; freg : register ; fctp : ctp) ; EXTERNAL ;
 343     PROCEDURE freeallregisters ; EXTERNAL ;
 344     PROCEDURE loadbase (flev : integer) ; EXTERNAL ;
 345     PROCEDURE sauvereg (freg : register ; fload : boolean) ; EXTERNAL ;
 346     PROCEDURE newbloc (freg : register) ; EXTERNAL ;
 347     PROCEDURE regenere (oldbloc : regpt) ; EXTERNAL ;
 348 
 349 (* FROM DECLARE *)
 350     PROCEDURE push_lab_pdl ; EXTERNAL ;
 351     PROCEDURE pop_lab_pdl ; EXTERNAL ;
 352 
 353 
 354 $OPTIONS page $
 355 
 356 (* **************************************************************************** *)
 357 (* *                                                                          * *)
 358 (* *                                                                          * *)
 359 (* *                                    STATEMENT GROUP                       * *)
 360 (* *                                                                          * *)
 361 (* *                                                                          * *)
 362 (* **************************************************************************** *)
 363 
 364     PROCEDURE statement ; FORWARD ;
 365 
 366 
 367 
 368 $OPTIONS page $
 369 
 370 (* ********************************************** COMPSTAT ******************** *)
 371 
 372     PROCEDURE compstat ;
 373 
 374 (* C.USED TO COMPILE    A  COMPOUND   STATEMENT.
 375    "BEGIN" HAS BEEN READ.
 376    .EXPECTS AN "END"
 377    C *)
 378 (* ERRORS DETECTED
 379    13: "END" EXPECTED
 380    14: ";"   EXPECTED
 381    61: ILLEGAL  BEGINNING SYMBOL FOR A STATEMENT
 382    E *)
 383       LABEL 1 ;                                   (* SKIP HERE WHEN A STATEMENT *)
 384                                                   (* CAN BEGIN *)
 385       BEGIN
 386         freeallregisters ;
 387         REPEAT
 388           insymbol ;
 389 1 :       statement ;
 390           freeallregisters ;
 391           IF errcl [no] = begsy THEN
 392             BEGIN
 393               error (14) ; GOTO 1 ;
 394             END ;
 395           IF no = 25 (* ELSE *) THEN
 396             BEGIN
 397               error (61) ; insymbol ; GOTO 1 ;
 398             END ;
 399         UNTIL no # 16 (* ; *) ;
 400         IF no = 22 (* "END" *) THEN
 401           BEGIN
 402             insymbol
 403           END
 404         ELSE error (13) ;
 405       END (* COMPSTAT *) ;
 406 
 407 
 408 $OPTIONS page $
 409 
 410 (* ************************************ WITHSTAT ****************************** *)
 411 
 412     PROCEDURE withstat ;
 413 
 414 (* C  COMPILE THE PASCAL STATEMENT
 415    WITH  <REC> [, REC]*   DO  <STATE>
 416    C *)
 417 (* E ERRORS DETECTED
 418    54: "DO" EXPECTED
 419    140: TYPE OF VARIABLE MUST BE RECORD
 420    250: TOO MANY NESTED SCOPES OF IDENTIFIERS
 421    E *)
 422       LABEL
 423         10,                                       (*  EXIT PROCEDURE *)
 424         20 ;                                      (*  CALL STATEMENT *)
 425                                                   (* WITHOUT CALLING INSYMBOL *)
 426       VAR
 427         oldtop, oldlcsave : integer ;
 428         currentfather, withnode : blocknodeptr ;
 429         withfile, withindex : integer ;
 430       BEGIN                                       (* WITHSTAT *)
 431 $OPTIONS compile = trace $
 432         IF stattrace > none THEN
 433           BEGIN
 434             write (mpcogout, '@@@ DEBUT WITHSTAT @@@ WITH TOP,LCSAVE  ', top, lcsave) ;
 435             nextline ;
 436           END ;
 437 $OPTIONS compile = true $
 438         withnode := NIL ;
 439         currentfather := currentnode ;
 440         oldtop := top ;                           (* ACTUAL LEVEL REACHED IN DISPLAY *)
 441         oldlcsave := lcsave ;
 442         lcsave := recadre (lcsave, bytesindword) ;
 443         IF lcsave > tmax THEN tmax := lcsave ;
 444         REPEAT                                    (* LOOP ON RECORD'S LIST *)
 445           insymbol ;
 446           withfile := symbolfile ;
 447           withindex := symbolindex ;
 448           freeallregisters ;
 449           withvariable := true ;
 450           currwithlist.nbr := 0 ;
 451           variab (false) ;                        (* NOT ALTERED HERE *)
 452           withvariable := false ;
 453           WITH gattr DO
 454             IF typtr # NIL THEN                   (* NO ERROR *)
 455               IF typtr@.form # records THEN
 456                 error (140) ELSE
 457                 IF top >= displimit THEN
 458                   error (250) ELSE
 459                   BEGIN
 460                     top := top + 1 ;
 461                     WITH display [top] DO
 462                       BEGIN
 463                         fname := typtr@.fstfld ;  (* FIRST FIELD NAME IN THE RECORD *)
 464                         new (withnode, withblock) ;
 465                         IF withnode = NIL THEN heaperror ; (* EXIT COMP *)
 466                         WITH withnode^ DO
 467                           BEGIN
 468                             blocktp := withblock ;
 469                             father := currentnode ;
 470                             recordptr := typtr ;
 471                             wstrfile := withfile ; wstrindex := withindex ;
 472                             IF symbolfile = wstrfile THEN
 473                               wstrlength := symbolindex - withindex
 474                             ELSE wstrlength := 0 ;
 475                             brother := currentnode^.son ;
 476                             currentnode^.son := withnode ;
 477                             son := NIL ;
 478                             codebegin := statnbr * 2 ;
 479                             codeend := 0 ;
 480                             first := typtr^.fstfld ;
 481                             currentnode := withnode ;
 482                             IF varissimple (gattr) AND (NOT typtr@.pack) THEN
 483                               BEGIN               (* EASY TO ADDRESS *)
 484                                 occur := cwith ; clevel := vlev ; cdspl := dplmt ;
 485                                 IF vlev = 0 THEN wbase := statics ELSE wbase := locals ;
 486                                 wdispl := dplmt DIV bytesinword ; windirect := false ;
 487                                 creflist := currwithlist ;
 488                               END (* EASY *) ELSE
 489                               BEGIN
 490                                 occur := vwith ; vdspl := lcsave ;
 491                                 lcsave := lcsave + bytesindword ;
 492                                 IF lcsave > tmax THEN tmax := lcsave ; vpack := typtr@.pack ;
 493                                                   (* BUILDS ITS POINTING ON THE RECORD *)
 494                                 loadadr (gattr, nreg) ; freebloc (currentbloc) ;
 495                                 genstand (pr6, vdspl DIV bytesinword,
 496                                   prinst [spri, currentpr], tn) ;
 497                                 wbase := locals ; wdispl := vdspl DIV bytesinword ; windirect := true ;
 498                                 vreflist := currwithlist ;
 499                               END (* NOT EASY *) ;
 500                           END (* WITH WITHNODE^ *) ;
 501                       END (* WITH DISPLAY[TOP] *) ;
 502                   END (* ALL IS OK,WITH GATTR *) ;
 503         UNTIL no # 15 (* , *) ;
 504         IF no # 31 (* DO *) THEN
 505           BEGIN
 506             IF gattr.typtr # NIL THEN error (54) ;
 507             skip (31) ;
 508             IF no # 31 THEN
 509               BEGIN
 510                 IF gattr.typtr = NIL THEN error (54) ;
 511                 IF errcl [no] = begsy THEN
 512                   GOTO 20 (* STATEMENT *) ELSE
 513                   GOTO 10 (* END PROC *) ;
 514               END ;
 515           END (* NO#31 *) ;
 516         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
 517         insymbol ;
 518 20 :
 519         freeallregisters ;
 520         push_lab_pdl ; statement ; pop_lab_pdl ;
 521 10 :
 522         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
 523 $OPTIONS compile = trace $
 524         IF stattrace = high THEN
 525           BEGIN
 526             write (mpcogout, '* RETURN IN WITHSTAT . TOP, LCSAVE  ARE NOW', top, lcsave) ;
 527             nextline ;
 528           END ;
 529 $OPTIONS compile = true $
 530         WHILE currentnode <> currentfather DO
 531           BEGIN
 532             currentnode^.codeend := statnbr * 2 ;
 533             currentnode := currentnode^.father ;
 534           END ;
 535         top := oldtop ;
 536         lcsave := oldlcsave ;
 537 $OPTIONS compile = trace $
 538         IF stattrace > low THEN
 539           BEGIN
 540             write (mpcogout, '@@@ FIN WITHSTAT @@@ WITH NO,TOP, LCSAVE ', no, top, lcsave) ;
 541             nextline ;
 542           END ;
 543 $OPTIONS compile = true $
 544       END (* WITHSTAT *) ;
 545 
 546 
 547 $OPTIONS page $
 548 
 549 (* ************************************ ASSIGN ******************************** *)
 550 
 551     PROCEDURE assign ;
 552 
 553 (* C   COMPILATION  OF
 554    <VARIABLE>  :=    <EXPRESSION>
 555    C *)
 556 (* E ERRORS DETECTED
 557    29: Same length strings expected
 558 
 559    51: ":=" EXPECTED
 560    109: REAL TO INT NOT ALLOWED
 561    145: TYPE CONFLICT
 562    146: FILES NOT ALLOWED HERE
 563    197: TRUNCATION  NOT ALLOWED
 564    303: VALUE ASSIGNED OUT OF BOUNDS
 565    E *)
 566       VAR
 567         check_done, len_in_desc : boolean ;
 568         strlen : integer ;
 569         locarray : setarray ; lretpt : lcstpt ;
 570         lbloc, rbloc : regpt ;
 571         lattr, tattr : attr ;
 572         generic : ctp ;
 573         lbase, rbase, lpr, rpr : preg ;
 574         ldisp, lsize, rsize, rdisp, lmod, rmod, suplr : integer ;
 575         ltag, lftag, rgtag : tag ;
 576         asserr, ended : boolean ;
 577         ddisp, target_length, loc1 : integer ;
 578         temp : ctp ;
 579         rqbox : regpt ;
 580       BEGIN                                       (* ASSIGN *)
 581 $OPTIONS compile = trace $
 582         IF stattrace > none THEN
 583           BEGIN
 584             write (mpcogout, '@@@ DEBUT ASSIGN @@@') ; nextline ;
 585           END ;
 586 $OPTIONS compile = true $
 587                                                   (* LEFT PART *)
 588         check_done := false ;
 589         len_in_desc := false ;
 590         asserr := false ;
 591         variable (true) ;
 592         lattr := gattr ;
 593         IF no # 20 (* := *) THEN
 594           BEGIN
 595             IF gattr.typtr # NIL THEN error (51) ;
 596             skip (20) ;
 597           END ;
 598         IF no = 20 (* := *) THEN
 599           BEGIN
 600             insymbol ;
 601             expression ;                          (* RIGHT PART  OF ASSIGNMENT *)
 602             WITH gattr DO
 603               IF typtr = NIL THEN
 604                 BEGIN
 605                   skip (46) ; generic := NIL ;
 606                 END ELSE
 607                 BEGIN
 608                   compatbin (lattr.typtr, typtr, generic) ;
 609                   IF generic = NIL THEN
 610                     asserr := true ;
 611                 END ;
 612             IF asserr THEN                        (* TRY STRING ASSIGNMENT *)
 613               IF lattr.typtr <> NIL
 614               THEN IF lattr.typtr^.father_schema = string_ptr THEN (* TARGET IS A STRING *)
 615                   WITH gattr DO
 616                     IF typtr = charptr (* RIGHT PART IS A CHARACTER *) THEN
 617                       BEGIN
 618                         IF varissimple (lattr) THEN
 619                           BEGIN
 620                             lbase := lattr.basereg ; ldisp := lattr.dplmt DIV bytesinword ;
 621                             currentbloc := NIL ;
 622                           END ELSE BEGIN
 623                             loadadr (lattr, nreg) ; lbase := currentpr ;
 624                             ldisp := 0
 625                           END ;
 626                         CASE kind OF
 627                           sval : BEGIN
 628                               IF currentbloc <> NIL THEN freebloc (currentbloc) ;
 629                               locarray [0] := 1 ; locarray [1] := val * twoto27 ;
 630                               enterlcst (locarray, lretpt) ;
 631                               enterundlab (lretpt^.lplace) ;
 632                               genstand (nreg, 0, iepp3, tic) ;
 633                               mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
 634                               geneism (imlr, ord (' '), p0t0r0) ;
 635                               gendesca (pr3, 0, 0, l9, 5, tn) ;
 636                               WITH lattr DO
 637                                 IF kind = varbl THEN usednameaddr := nameaddr ;
 638                               gendesca (lbase, ldisp, 0, l9, 5, tn) ;
 639                             END ;
 640                           lval : BEGIN
 641                               IF currentbloc <> NIL THEN freebloc (currentbloc) ;
 642                               genstand (nreg, 27, opaq [shiftl, ldreg], tn) ;
 643                               genstand (lbase, ldisp + 1, opaq [stor, ldreg], tn) ;
 644                               genstand (nreg, 1, opaq [load, ldreg], tdl) ;
 645                               genstand (lbase, ldisp, opaq [stor, ldreg], tn) ;
 646                             END ;
 647                           varbl : BEGIN
 648                               lbloc := currentbloc ;
 649                               IF varissimple (gattr) THEN
 650                                 BEGIN
 651                                   rbase := gattr.basereg ; rdisp := gattr.dplmt DIV bytesinword ;
 652                                 END ELSE BEGIN
 653                                   loadadr (gattr, nreg) ; rbase := currentpr ;
 654                                   rdisp := 0 ; freebloc (currentbloc) ;
 655                                 END ;
 656                               IF lbloc <> NIL THEN BEGIN
 657                                   regenere (lbloc) ; freebloc (lbloc) ;
 658                                 END ELSE IF lattr.basebloc <> NIL THEN regenere (lattr.basebloc) ;
 659                               mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
 660                               geneism (imlr, ord (' '), p0t0r0) ;
 661                               usednameaddr := gattr.nameaddr ;
 662                               IF pckd THEN gendesca (rbase, rdisp, 0, l9, 1, tn)
 663                               ELSE gendesca (rbase, rdisp, 3, l9, 1, tn) ;
 664                               usednameaddr := lattr.nameaddr ;
 665                               gendesca (lbase, ldisp + 1, 0, l9, 1, tn) ;
 666                               genstand (nreg, 1, ilda, tdl) ;
 667                               genstand (lbase, ldisp, ista, tn) ;
 668                             END
 669                         END ;
 670                         freeattr (gattr) ; freeattr (lattr) ;
 671                       END
 672                     ELSE
 673                       IF isstring (gattr) THEN
 674                         IF lattr.typtr^.actual_parameter_list = NIL THEN (* nothing *)
 675                         ELSE
 676                           BEGIN
 677                             loadadr (lattr, nreg) ; (* ADDRESS OF TARGET *)
 678                             lpr := currentpr ; lbloc := currentbloc ;
 679                             IF conformantdim (gattr.typtr) THEN
 680                               BEGIN
 681                                 init_desc_address (gattr.nameaddr, gattr) ;
 682                                 sauvereg (rq, false) ;
 683                                 regenere (gattr.descbloc) ;
 684                                 genstand (gattr.descreg, 1, isbq, tn) ;
 685                                 genstand (gattr.descreg, 0, isbq, tn) ;
 686                                 genstand (nreg, 1, iadq, tdl) ;
 687                                 rpr := gattr.basereg ; rbloc := gattr.basebloc ;
 688                               END
 689                             ELSE BEGIN            (* NOT CONFORMANT *)
 690                                 loadadr (gattr, nreg) ;
 691                                 rpr := currentpr ; rbloc := currentbloc ;
 692                                 CASE kind OF
 693                                   chain : strlen := alfactp^.alfalong ;
 694                                   varbl : strlen := typtr^.hi - typtr^.lo + 1 ;
 695                                 END ;
 696                                 sauvereg (rq, false) ;
 697                                 gencstecode (strlen, ildq) ;
 698                                 IF asscheck THEN
 699                                   IF lattr.typtr^.actual_parameter_list^.klass = konst THEN
 700                                     IF strlen > lattr.typtr^.actual_parameter_list^.values THEN
 701                                       error (273) ;
 702                                 check_done := true ;
 703                               END ;
 704                             WITH lattr.typtr^.actual_parameter_list^ DO
 705                               IF klass = konst THEN
 706                                 IF values < twoto12 THEN len_in_desc := true ELSE
 707                                   gencstecode (values, ilda)
 708                               ELSE BEGIN
 709                                   addressvar (lattr.typtr^.actual_parameter_list, tattr, false) ;
 710                                   transfer (tattr, inacc) ; freeattr (tattr) ;
 711                                 END ;
 712                             regenere (rbloc) ; regenere (lbloc) ;
 713                             IF len_in_desc THEN mfari2 := a1r0i0 ELSE
 714                               mfari2 := a1r1i0 ; mfari1 := a1r1i0 ;
 715                             geneism (imlr, ord (' '), p0t0r0) ;
 716                             gendesca (rpr, 0, 0, l9, 0, tql) ;
 717                             IF len_in_desc THEN
 718                               gendesca (lpr, 1, 0, l9, lattr.typtr^.actual_parameter_list^.values, tn)
 719                             ELSE
 720                               gendesca (lpr, 1, 0, l9, 0, tal) ;
 721                             genstand (lpr, 0, istq, tn) ;
 722                             freebloc (rbloc) ;
 723                             IF asscheck THEN
 724                               IF NOT check_done THEN
 725                                 BEGIN
 726                                   genstand (lpr, 0, icmpa, tn) ;
 727                                   loc1 := indfich ; genstand (nreg, 0, itpl, tic) ;
 728                                   genexceptcode (stringlength_assignment_error, rq) ;
 729                                   inser (cb, loc1) ;
 730                                 END ;
 731                             freebloc (lbloc) ;
 732                             freeattr (gattr) ; freeattr (lattr) ;
 733                           END
 734                       ELSE IF gattr.typtr^.father_schema = string_ptr THEN
 735                           IF lattr.typtr^.actual_parameter_list = NIL THEN (* nothing *)
 736                           ELSE
 737                             BEGIN
 738                               loadadr (lattr, nreg) ;
 739                               lpr := currentpr ; lbloc := currentbloc ;
 740                               loadadr (gattr, nreg) ;
 741                               rpr := currentpr ; rbloc := currentbloc ;
 742                               IF asscheck THEN
 743                                 BEGIN
 744                                   WITH lattr.typtr^.actual_parameter_list^ DO
 745                                     IF klass = konst THEN
 746                                       IF gattr.typtr^.actual_parameter_list^.klass <> konst THEN
 747                                         gencstecode (values, ilda)
 748                                       ELSE BEGIN
 749                                           IF values >= gattr.typtr^.actual_parameter_list^.values THEN check_done := true
 750                                         END
 751                                     ELSE BEGIN
 752                                         addressvar (lattr.typtr^.actual_parameter_list, tattr, false) ;
 753                                         transfer (tattr, inacc) ; freeattr (tattr) ;
 754                                       END ;
 755                                   genstand (rpr, 0, icmpa, tn) ;
 756                                   loc1 := indfich ; genstand (nreg, 0, itpl, tic) ;
 757                                   genexceptcode (stringlength_assignment_error, ra) ;
 758                                   inser (cb, loc1) ;
 759                                 END ;
 760                               regenere (rbloc) ; regenere (lbloc) ;
 761                               mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
 762                               genstand (rpr, 0, ildq, tn) ; genstand (nreg, 4, iadq, tdl) ;
 763                               geneism (imlr, ord (' '), p0t0r0) ;
 764                               gendesca (rpr, 0, 0, l9, 0, tql) ;
 765                               gendesca (lpr, 0, 0, l9, 0, tql) ;
 766                               freebloc (lbloc) ; freebloc (rbloc) ;
 767                               freeattr (gattr) ; freeattr (lattr) ;
 768                             END
 769                         ELSE error (145)
 770                 ELSE error (145) ;
 771             IF generic # NIL THEN
 772               WITH gattr DO
 773                 CASE generic@.form OF
 774                   reel :
 775                     BEGIN
 776                       IF gattr.typtr # realptr THEN
 777                         convreal (gattr) ELSE
 778                         IF lattr.typtr # realptr THEN
 779                           error (109) ;
 780                       transfer (gattr, inacc) ;
 781                       transfer (lattr, out) ;
 782                     END (* REEL *) ;
 783                   numeric, scalar :
 784                     BEGIN
 785                       IF kind = sval THEN
 786                         checkminmax (val, lattr.typtr, 303) ELSE
 787                         IF asscheck THEN
 788                           BEGIN
 789                             choicerarq ;
 790                             checkbnds (asserrcode, ldreg, lattr.typtr) ;
 791                           END (* asschecks *) ;
 792                       ended := false ;
 793                       IF kind = sval THEN
 794                         BEGIN
 795                           IF lattr.pckd THEN
 796                             BEGIN
 797                               IF lattr.access # pointable THEN
 798                                 IF lattr.inxbloc = NIL THEN
 799                                   IF lattr.inxmem = 0 THEN
 800                                     IF packedsize (lattr.typtr) = byteinbyte
 801                                                   (* SHORTER SAID 1 *)
 802                                     THEN
 803                                       BEGIN
 804                                         IF val < 0 THEN (* 2'S COMPLEMENT *)
 805                                           val := val + twoto9 ;
 806                                         calcvarient (lattr, lbase, ldisp, ltag) ;
 807                                         mfari1 := a0r0i0 ; (* DUMMY *)
 808                                         mfari2 := a1r0i0 ;
 809                                         mfreg2 := ltag ;
 810                                         geneism (imlr, val, p0t0r0) ;
 811                                         gendesca (nreg, 0, 0, l9, 0, tn) ;
 812                                         WITH lattr DO
 813                                           IF kind = varbl THEN usednameaddr := nameaddr ELSE
 814                                             IF kind = chain THEN usednameaddr := alfactp ;
 815                                         gendesca (lbase, ldisp,
 816                                           lattr.dplmt MOD bytesinword, l9, byteinbyte, tn) ;
 817                                         ended := true ;
 818                                       END (* SIZE 1 *) ;
 819                             END (* LATTR.PCKD *) ELSE
 820                             IF val = 0 THEN
 821                               BEGIN
 822                                 calcvarient (lattr, lbase, ldisp, ltag) ;
 823                                 WITH lattr DO
 824                                   IF kind = varbl THEN usednameaddr := nameaddr ELSE
 825                                     IF kind = chain THEN usednameaddr := alfactp ;
 826                                 genstand (lbase, ldisp, istz, ltag) ;
 827                                 ended := true ;
 828                               END (* VAL=0 *) ;
 829                         END (* KIND=SVAL *) ;
 830                       IF NOT ended THEN
 831                         BEGIN
 832                           choicerarq ;
 833                           transfer (lattr, out) ;
 834                         END (* NOT ENDED *) ;
 835                     END (* NUMERIC,SCALAR *) ;
 836                   power, pointer :
 837                     IF typtr = lamptr THEN
 838                       BEGIN
 839                         IF varissimple (lattr) THEN
 840                           BEGIN
 841                             lbase := lattr.basereg ;
 842                             ldisp := lattr.dplmt DIV bytesinword ;
 843                           END ELSE
 844                           BEGIN
 845                             loadadr (lattr, nreg) ; lbase := currentpr ;
 846                             freebloc (currentbloc) ; ldisp := 0 ;
 847                             lattr.dplmt := 0 ;
 848                           END ;
 849                         IF lattr.pckd THEN
 850                           lsize := packedsize (lattr.typtr) ELSE
 851                           lsize := lattr.typtr@.size ;
 852                         mfari1 := a0r0i0 ; (* DUMMY *) mfari2 := a1r0i0 ;
 853                         geneism (imlr, 0 (* FILL BYTE *), p0t0r0) ;
 854                         gendesca (nreg, 0, 0, l9, 0, tn) ;
 855                         WITH lattr DO
 856                           IF kind = varbl THEN usednameaddr := nameaddr ELSE
 857                             IF kind = chain THEN usednameaddr := alfactp ;
 858                         gendesca (lbase, ldisp, lattr.dplmt MOD bytesinword, l9, lsize, tn) ;
 859                       END (* LAMPTR *) ELSE
 860                       BEGIN
 861                         IF generic^.form = power THEN
 862                           IF gattr.kind = sval THEN
 863                             BEGIN
 864                               checkminmax (gattr.val MOD 1000, lattr.typtr^.elset, 305) ;
 865                               checkminmax (gattr.val DIV 1000, lattr.typtr^.elset, 305) ;
 866                             END ;
 867                         transfer (gattr, inacc) ;
 868                         transfer (lattr, out) ;
 869                       END ;
 870                   arrays, records :
 871                     IF NOT conformantdim (lattr.typtr) THEN
 872                       BEGIN
 873                         lsize := lattr.typtr@.size ;
 874                         IF isstring (gattr) THEN
 875                           BEGIN
 876                             IF kind = chain THEN
 877                               rsize := alfactp@.alfalong ELSE
 878                               rsize := typtr@.size ;
 879                             IF lsize < rsize THEN
 880                               error (197) ;
 881                           END (* ISSTRING *) ELSE
 882                           rsize := lsize ;
 883                         rbase := nreg ;
 884                         IF kind # chain THEN
 885                           IF varissimple (gattr) THEN
 886                             BEGIN
 887                               rbase := basereg ;
 888                               rdisp := dplmt DIV bytesinword ; rmod := dplmt MOD bytesinword ;
 889                             END ;
 890                         IF rbase = nreg THEN
 891                           BEGIN
 892                             loadadr (gattr, pr3) ;
 893                             rbase := pr3 ; rdisp := 0 ; rmod := 0 ;
 894                           END ;
 895                         IF varissimple (lattr) THEN
 896                           BEGIN
 897                             lbase := lattr.basereg ; ldisp := lattr.dplmt DIV bytesinword ;
 898                             lmod := lattr.dplmt MOD bytesinword ;
 899                           END ELSE
 900                           BEGIN
 901                             lbase := pr2 ; loadadr (lattr, pr2) ; ldisp := 0 ;
 902                             lmod := 0 ;
 903                           END ;
 904                         suplr := sup (rsize, lsize) ;
 905                         IF envstandard <> stdextend THEN
 906                           IF rsize <> lsize THEN
 907                             error (29) ;
 908                         IF suplr < twoto12 THEN
 909                           BEGIN
 910                             mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; lftag := tn ; rgtag := tn ;
 911                           END ELSE
 912                           BEGIN
 913                             mfari1 := a1r1i0 ; mfari2 := a1r1i0 ; lftag := tx6 ; rgtag := tx7 ;
 914                             IF suplr > twoto17m1 THEN
 915                               error (307) ELSE
 916                               BEGIN
 917                                 genstand (nreg, lsize, ieax6, tn) ;
 918                                 genstand (nreg, rsize, ieax7, tn) ;
 919                               END ;
 920                             lsize := 0 ; rsize := 0 ;
 921                           END ;
 922                         geneism (imlr, ord (' '), p0t0r0) ;
 923                         WITH gattr DO
 924                           IF kind = varbl THEN usednameaddr := nameaddr ELSE
 925                             IF kind = chain THEN usednameaddr := alfactp ;
 926                         gendesca (rbase, rdisp, rmod, l9, rsize, rgtag) ;
 927                         WITH lattr DO
 928                           IF kind = varbl THEN usednameaddr := nameaddr ELSE
 929                             IF kind = chain THEN usednameaddr := alfactp ;
 930                         gendesca (lbase, ldisp, lmod, l9, lsize, lftag) ;
 931                       END (* array not conf, records *) ELSE
 932                       BEGIN
 933                         init_desc_address (lattr.nameaddr, lattr) ;
 934                                                   (* COMPUTE SIZE NOW *)
 935                         sauvereg (rq, true) ; sauvereg (ra, false) ;
 936                         rqbox := currentbloc ;
 937 
 938                         ddisp := 0 ;
 939                         temp := lattr.typtr ;
 940                         WHILE conformantdim (temp^.aeltype) DO
 941                           BEGIN
 942                             ddisp := ddisp + 3 ;
 943                             temp := temp^.aeltype ;
 944                           END ;
 945                         regenere (lattr.descbloc) ;
 946                         genstand (lattr.descreg, 1 + ddisp, ildq, tn) ; (* MAX       *)
 947                         genstand (lattr.descreg, ddisp, isbq, tn) ; (*   - MIN   *)
 948                         genstand (nreg, 1, iadq, tdl) ; (*    +1     *)
 949                         genstand (lattr.descreg, 2 + ddisp, impy, tn) ; (*  * SUBSIZE   *)
 950                         IF NOT lattr.typtr^.pack THEN (* SIZE IS IN WORDS *)
 951                           genstand (nreg, 2, iqls, tn) ; (* IN BYTES NOW *)
 952                         freebloc (lattr.descbloc) ;
 953 
 954                         init_desc_address (gattr.nameaddr, gattr) ;
 955                         freebloc (gattr.descbloc) ;
 956 
 957                         mfari1 := a1r1i0 ;
 958                         mfari2 := a1r1i0 ;
 959                         regenere (rqbox) ; regenere (lattr.basebloc) ; regenere (gattr.basebloc) ;
 960                         IF lattr.typtr^.pack THEN (* SIZE IS IN BITS *)
 961                           BEGIN
 962                             geneism (icsl, 3, p0t0r0) ;
 963                             gendescb (gattr.basereg, 0, 0, 0, 0, tql) ;
 964                             gendescb (lattr.basereg, 0, 0, 0, 0, tql) ;
 965                           END
 966                         ELSE
 967                           BEGIN
 968                             geneism (imlr, ord (' '), p0t0r0) ;
 969                             gendesca (gattr.basereg, 0, 0, l9, 0, tql) ;
 970                             gendesca (lattr.basereg, 0, 0, l9, 0, tql) ;
 971                           END ;
 972 
 973                         freeattr (gattr) ; freeattr (lattr) ; freebloc (rqbox) ;
 974                       END ;
 975                   files : error (146) ;
 976                 END (* CASE GENERIC@.FORM,WITH GATTR *) ;
 977           END (* NO=20 *) ;
 978         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
 979 $OPTIONS compile = trace $
 980         IF stattrace > low THEN
 981           BEGIN
 982             write (mpcogout, '@@@ FIN ASSIGN @@@ WITH NO', no : 4) ; nextline ;
 983           END ;
 984 $OPTIONS compile = true $
 985       END (* ASSIGN *) ;
 986 
 987 
 988 $OPTIONS page $
 989 
 990 (* ************************************ REPEATSTAT **************************** *)
 991 
 992     PROCEDURE repeatstat ;
 993 
 994 (* C .COMPILATION  OF   REPEAT   <STATE> [;STATE]*  UNTIL  <EXPRESSION>
 995    .GENJUMP GENERATES  A SKIP IF FALSE
 996    C *)
 997 (* E ERRORS DETECTED
 998    6: TYPE OF EXPRESSION MUST BE BOOLEAN
 999    14: ";"  EXPECTED
1000    53: "UNTIL" EXPECTED
1001    61: ILLEGAL BEGINNING SYMBOL FOR A STATEMENT
1002    E *)
1003       LABEL
1004         10,                                       (* INSYMBOL BEFORE CALL OF STATEMENT *)
1005         20 ;                                      (* CALL OF STATEMENT *)
1006       VAR
1007         locrpt : integer ;
1008         dummy : integer ;
1009       BEGIN                                       (* REPEATSTAT *)
1010 $OPTIONS compile = trace $
1011         IF stattrace > none THEN
1012           BEGIN
1013             write (mpcogout, '@@@ DEBUT REPEATSTAT @@@') ; nextline ;
1014           END ;
1015 $OPTIONS compile = true $
1016         locrpt := cb ;                            (* RETURN PLACE *)
1017         push_lab_pdl ;
1018         REPEAT                                    (* LOOP  ON  STATEMENTS *)
1019 10 :
1020           insymbol ;
1021 20 :
1022           freeallregisters ;
1023           statement ;
1024           IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1025           IF errcl [no] = begsy THEN
1026             BEGIN
1027               error (14) ; GOTO 20 ;
1028             END ;
1029           IF no = 25 (* ELSE *) THEN
1030             BEGIN
1031               error (61) ; GOTO 10 ;
1032             END ;
1033         UNTIL no # 16 (* ; *) ;
1034         pop_lab_pdl ;
1035         IF no # 29 (* UNTIL *) THEN
1036           error (53) ELSE
1037           BEGIN
1038             IF mapswitch THEN statement_begins (true) ;
1039             insymbol ;
1040             freeallregisters ;
1041             expression ;
1042             IF gattr.typtr # NIL THEN
1043               BEGIN
1044                 IF gattr.typtr # boolptr THEN
1045                   error (6) ELSE
1046                   genjump (dummy, locrpt) ;
1047               END ELSE
1048               skip (46) ;
1049             IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1050           END (* UNTIL FOUND *) ;
1051 $OPTIONS compile = trace $
1052         IF stattrace > low THEN
1053           BEGIN
1054             write (mpcogout, '@@@ FIN REPEATSTAT @@@ WITH NO', no : 4) ; nextline ;
1055           END ;
1056 $OPTIONS compile = true $
1057       END (* REPEATSTAT *) ;
1058 
1059 
1060 $OPTIONS page $
1061 
1062 (* ************************************ WHILESTAT ***************************** *)
1063 
1064     PROCEDURE whilestat ;
1065 
1066 (* C   COMPILATION  OF  WHILE  <EXP> DO <STATE>
1067    C *)
1068 (* E ERRORS DETECTED
1069    6: BOOLEAN EXPRESSION EXPECTED
1070    54: "DO" EXPECTED
1071    E *)
1072       LABEL
1073         10,                                       (* EXIT PROCEDURE *)
1074                                                   (* SKIPS CALL OF STATEMENT *)
1075         20 ;                                      (* CALL OF STATEMENT *)
1076       VAR
1077         locret, locskip : integer ;
1078       BEGIN                                       (* WHILESTAT *)
1079 $OPTIONS compile = trace $
1080         IF stattrace > none THEN
1081           BEGIN
1082             write (mpcogout, '@@@ DEBUT WHILESTAT @@@') ; nextline ;
1083           END ;
1084 $OPTIONS compile = true $
1085         locret := cb ;
1086         locskip := 0 ;                            (* DEFAULT MEANS NO INSER *)
1087         insymbol ;
1088         freeallregisters ;
1089         expression ;
1090         IF gattr.typtr # NIL THEN
1091           BEGIN
1092             IF gattr.typtr # boolptr THEN
1093               error (6) ELSE
1094               genjump (locskip, 0) ;
1095           END ;
1096         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1097         IF no # 31 (* DO *) THEN
1098           BEGIN
1099             IF gattr.typtr # NIL THEN error (54) ;
1100             skip (31) ;
1101             IF no # 31 THEN
1102               BEGIN
1103                 IF gattr.typtr = NIL THEN error (54) ;
1104                 IF errcl [no] = begsy THEN
1105                   GOTO 20 ELSE
1106                   GOTO 10 ;
1107               END ;
1108           END (* NO#31 *) ;
1109         insymbol ;
1110 20 :
1111         freeallregisters ;
1112         push_lab_pdl ; statement ; pop_lab_pdl ;
1113         genstand (nreg, (locret - cb) DIV bytesinword, itra, tic) ;
1114         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1115         IF locskip # 0 THEN
1116           inser (cb, locskip) ;
1117 10 :
1118 $OPTIONS compile = trace $
1119         IF stattrace > low THEN
1120           BEGIN
1121             write (mpcogout, '@@@ FIN WHILESTAT @@@ WITH NO:', no : 4) ; nextline ;
1122           END ;
1123 $OPTIONS compile = true $
1124       END (* WHILESTAT *) ;
1125 
1126 
1127 $OPTIONS page $
1128 
1129 (* ************************************ FORSTAT ******************************* *)
1130 
1131     PROCEDURE forstat ;
1132 
1133 (* C      CHECKS  CONTROL VARIABLE
1134    COMPUTE FIRST EXP
1135    COMPUTE SECOND EXP
1136    STORE   IF NOT SVAL
1137    TEST    ONE EXECUT
1138    E1   STORE   FIRST IN CONTROL
1139    E2
1140    <STATEMENT>
1141    RELOAD  CONTROL
1142    TEST    ENDED
1143    YES     GOTO E3
1144    NO      IF"TO"      AOS  ,GOTO  E2
1145    IF "DOWNTO" SUB 1,GOTO  E1
1146    E3
1147    C *)
1148 (* E ERRORS DETECTED
1149    2: ID.  EXPECTED
1150    51: ":=" EXPECTED
1151    54: "DO" EXPECTED
1152    55: "TO/DOWNTO" EXPECTED
1153    103: ID. IS NOT OF APPROPRIATE CLASS
1154    104: ID. NOT DECLARED
1155    145: TYPE CONFLICT
1156    194: CONTROL VARIABLE MUST BE DECLARED AND USED AT SAME LEVEL
1157    195:  SCALAR OR NUMERIC FOR CONTROL VARIABLE
1158    196:  VARIABLE MUST NOT BE ASSIGNED
1159    199: CONTROL VARIABLE CANNOT BE FORMAL OR EXPORTABLE
1160    303:  VALUE ASSIGNED  OUT OF BOUNDS
1161    E *)
1162       LABEL
1163         10,                                       (* EXIT PROC *)
1164         20 ;                                      (* STATEMENT *)
1165       VAR
1166         lptcont : ctp ;                           (* NIL  IF ERROR ON CONTROL VARIABLE *)
1167         lstate : integer ;                        (* REACHES  3  IF NO ERROR *)
1168         oldlcsave, retdispw : integer ;
1169         controlnameaddr, typvar, generic : ctp ;
1170         ldispw, lcl, supval, highdispw, locskip1, locskip2, downret, toret : integer ;
1171         lbase : preg ;
1172         totransfer, skipall, lcompare, supissval : boolean ;
1173         lattr : attr ;
1174         ldest : destination ;
1175         lstor, ejump, bjump, lsub, lcomp, lload : istand ;
1176       BEGIN                                       (* FORSTAT *)
1177 $OPTIONS compile = trace $
1178         IF stattrace > none THEN
1179           BEGIN
1180             write (mpcogout, '@@@ DEBUT FORSTAT @@@ WITH LCSAVE:', lcsave) ; nextline ;
1181           END ;
1182 $OPTIONS compile = true $
1183         controlnameaddr := NIL ;
1184         lstate := 0 ;                             (* MUST BE 3  IF NO ERROR *)
1185         oldlcsave := lcsave ;
1186         highdispw := lcsave DIV bytesinword ;
1187         lcsave := lcsave + bytesinword ;
1188         IF lcsave > tmax THEN tmax := lcsave ;
1189         lptcont := NIL ;                          (* DEFAULT  IF ERROR *)
1190         typvar := NIL ;
1191         insymbol ;                                (* CONTROL VARIABLE *)
1192         IF no # 1 THEN
1193           error (2) ELSE
1194           BEGIN
1195             search ;
1196             IF ctptr = NIL THEN
1197               error (104) ELSE
1198               BEGIN
1199                 IF symbolmap THEN nameisref (ctptr, symbolfile, -symbolline) ;
1200                 IF ctptr@.klass # vars THEN
1201                   error (103) ELSE
1202                   IF ctptr@.vtype # NIL THEN
1203                     IF NOT (ctptr@.vtype@.form IN [numeric, scalar]) THEN
1204                       error (195) ELSE
1205                       BEGIN lstate := 1 ;         (* NO ERROR HERE FLAG *)
1206                         IF ctptr@.vlevel # level THEN error (194) ;
1207                         IF ctptr@.visreadonly THEN error (196) ;
1208                         IF ctptr@.vkind # actual THEN error (199) ;
1209                         lptcont := ctptr ; typvar := ctptr@.vtype ;
1210                         ldispw := ctptr@.vaddr DIV bytesinword ;
1211                         IF level = 0 THEN
1212                           lbase := prstatic ELSE lbase := pr6 ;
1213                         controlnameaddr := ctptr ;
1214                         WITH ctptr@ DO
1215                           BEGIN
1216                             visused := true ;
1217                             visset := true ;      (* VISREADONLY AFTER "DO" *)
1218                           END ;
1219                         insymbol ;
1220                       END ;
1221               END ;
1222           END (* NO=1 *) ;
1223                                                   (* CHECK  := *)
1224         IF no # 20 THEN
1225           BEGIN
1226             IF lptcont # NIL THEN error (51) ;
1227             skip (20) ;
1228             IF no # 20 THEN
1229               BEGIN lstate := 0 ;                 (* ERROR FLAG *)
1230                 IF lptcont = NIL THEN error (51) ;
1231                 IF errcl [no] = begsy THEN
1232                   GOTO 20 (* STATEMENT *) ELSE
1233                   GOTO 10 (* EXIT PROC *) ;
1234               END ;
1235           END ;
1236                                                   (* ANALYSIS  OF  FIRST EXPRESSION *)
1237         freeallregisters ;
1238         insymbol ; expression ;
1239         compatbin (typvar, gattr.typtr, generic) ;
1240         IF (generic = NIL) OR (generic = realptr) THEN
1241           error (145) ELSE
1242           BEGIN                                   (* NO TYPE ERROR *)
1243             WITH gattr DO
1244               IF kind = sval THEN
1245                 checkminmax (val, typvar, 303) ELSE
1246                 BEGIN                             (* NOT SVAL *)
1247                   totransfer := true ;
1248                   IF kind = varbl THEN
1249                     IF NOT asscheck THEN
1250                       IF varissimple (gattr) THEN
1251                         totransfer := false ;
1252                   IF totransfer THEN
1253                     BEGIN
1254                       IF kind # lval THEN
1255                         transfer (gattr, inq) ;
1256                       IF asscheck THEN
1257                         checkbnds (forerricode, ldreg, typvar) ;
1258                     END (* TOTRANSFER *) ;
1259                 END (* NOT SVAL, WITH GATTR *) ;
1260             lstate := lstate + 1 ;                (* NO ERROR HERE FLAG *)
1261           END (* NO TYPE ERROR *) ;
1262                                                   (* ANALYSIS  OF  TO/DOWNTO *)
1263         IF no # 33 (* TO/DOWNTO *) THEN
1264           BEGIN
1265             IF gattr.typtr # NIL THEN error (55) ;
1266             skip (33) ;
1267             IF no # 33 THEN
1268               BEGIN lstate := 0 ;                 (* ERROR FLAG *)
1269                 IF gattr.typtr = NIL THEN error (55) ;
1270                 IF errcl [no] = begsy THEN
1271                   GOTO 20 (* STATE *) ELSE
1272                   GOTO 10 ;                       (* END PROC *)
1273               END ;
1274           END (* NO#33 *) ;
1275                                                   (* ANALYSIS OF ENDING EXPRESSION *)
1276         lcl := cl ;                               (* 1:TO  2:DOWNTO *)
1277         lattr := gattr ;
1278         insymbol ; expression ;
1279         compatbin (typvar, gattr.typtr, generic) ;
1280         IF (generic = NIL) OR (generic = realptr) THEN
1281           error (145) ELSE
1282           BEGIN                                   (* NO TYPE ERR *)
1283             WITH gattr DO
1284               IF kind = sval THEN
1285                 BEGIN
1286                   supissval := true ; supval := val ;
1287                   checkminmax (val, typvar, 303) ;
1288                 END (* SVAL *) ELSE
1289                 BEGIN                             (* NOT SVAL *)
1290                   supissval := false ;
1291                   IF kind # lval THEN
1292                     BEGIN
1293                       IF lattr.kind # lval THEN ldest := inacc ELSE
1294                         IF lattr.ldreg = ra THEN ldest := inq ELSE ldest := inacc ;
1295                       transfer (gattr, ldest) ;
1296                     END ;
1297                   IF asscheck THEN
1298                     checkbnds (forerrscode, ldreg, typvar) ;
1299                   usednameaddr := controlnameaddr ;
1300                   genstand (pr6, highdispw, opaq [stor, ldreg], tn) ;
1301                   freebloc (ldregbloc) ;
1302                 END (* NOT SVAL,WITH GATTR *) ;
1303             lstate := lstate + 1 ;                (* NO ERROR HERE *)
1304           END (* NO TYPE ERROR *) ;
1305                                                   (* ANALYSIS FOR DO *)
1306         IF no # 31 (* DO *) THEN
1307           BEGIN
1308             IF gattr.typtr # NIL THEN error (54) ;
1309             skip (31) ;
1310             IF no # 31 THEN
1311               BEGIN lstate := 0 ;                 (* ERROR FLAG *)
1312                 IF gattr.typtr = NIL THEN error (54) ;
1313                 IF errcl [no] = begsy THEN
1314                   GOTO 20 (* STATEMENT *) ELSE
1315                   GOTO 10 (* EXIT PROC *) ;
1316               END ;
1317           END (* NO # 31 *) ;
1318         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1319                                                   (*  CODE  GENERATION *)
1320         IF lstate = 3 (* NO ERROR *) THEN
1321           BEGIN
1322             skipall := false ; lcompare := true ;
1323             IF lattr.kind = sval THEN
1324               BEGIN
1325                 IF supissval THEN
1326                   BEGIN
1327                     lcompare := false ;
1328                     IF lcl = 1 (* TO *) THEN
1329                       BEGIN
1330                         IF lattr.val > supval THEN skipall := true ;
1331                       END ELSE                    (* DOWNTO *)
1332                       IF lattr.val < supval THEN skipall := true ;
1333                   END (* SUPISSVAL *) ;
1334               END (* LATTR IS SVAL *) ELSE
1335               IF lattr.kind = lval THEN
1336                 lvalvarbl (lattr) ;
1337             IF lattr.kind # lval THEN
1338               transfer (lattr, inacc) ;
1339             IF lattr.ldreg = ra THEN
1340               BEGIN
1341                 lcomp := icmpa ; lstor := ista ; lload := ilda ; lsub := isba ;
1342               END (* RA *) ELSE
1343               BEGIN                               (* RQ *)
1344                 lcomp := icmpq ; lstor := istq ; lload := ildq ; lsub := isbq ;
1345               END (* RQ *) ;
1346             IF lcl = 1 (* TO *) THEN
1347               BEGIN bjump := itpnz ; ejump := itpl ; END ELSE
1348               BEGIN bjump := itmi ; ejump := itmoz END ;
1349             IF skipall THEN
1350               BEGIN
1351                 locskip1 := indfich ; genstand (nreg, 0, itra, tic) ;
1352               END ELSE
1353               IF lcompare THEN
1354                 BEGIN
1355                   IF supissval THEN
1356                     gencstecode (supval, lcomp) ELSE
1357                     genstand (pr6, highdispw, lcomp, tn) ;
1358                   locskip1 := indfich ; genstand (nreg, 0, bjump, tic) ;
1359                 END (* LCOMPARE *) ELSE locskip1 := 0 ;
1360             downret := cb ; usednameaddr := controlnameaddr ; genstand (lbase, ldispw, lstor, tn) ;
1361             freebloc (lattr.ldregbloc) ;
1362             toret := cb ;
1363           END (* NO ERROR *) ;
1364         insymbol ;
1365 20 :
1366         IF lptcont # NIL THEN lptcont@.visreadonly := true ;
1367         freeallregisters ;
1368         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1369         push_lab_pdl ; statement ; pop_lab_pdl ;
1370         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1371                                                   (* NOW  ENDING  OF LOOP *)
1372         IF lstate = 3 (* NO ERROR *) THEN
1373           BEGIN
1374                                                   (* RELOAD  CONTROL VARIABLE *)
1375             IF mapswitch THEN statement_begins (true) ;
1376             usednameaddr := controlnameaddr ;
1377             genstand (lbase, ldispw, lload, tn) ;
1378             IF supissval THEN
1379               gencstecode (supval, lcomp) ELSE
1380               genstand (pr6, highdispw, lcomp, tn) ;
1381             locskip2 := indfich ; genstand (nreg, 0, ejump, tic) ;
1382             IF lcl = 1 THEN
1383               BEGIN
1384                 usednameaddr := controlnameaddr ;
1385                 genstand (lbase, ldispw, iaos, tn) ;
1386                 retdispw := (toret - cb) DIV bytesinword ;
1387               END ELSE
1388               BEGIN                               (* DOWNTO *)
1389                 genstand (nreg, 1, lsub, tdl) ;
1390                 retdispw := (downret - cb) DIV bytesinword ;
1391               END (* DOWNTO *) ;
1392             genstand (nreg, retdispw, itra, tic) ;
1393             IF locskip1 # 0 THEN inser (cb, locskip1) ;
1394             inser (cb, locskip2) ;
1395           END (* LSTATE=3  NO ERROR *) ;
1396         IF lptcont # NIL THEN
1397           lptcont@.visreadonly := false ;
1398 10 :                                              (* EXIT PROC *)
1399         lcsave := oldlcsave ;
1400         IF mapswitch THEN statement_ends (3) ;    (* "end" *)
1401 $OPTIONS compile = trace $
1402         IF stattrace > low THEN
1403           BEGIN
1404             write (mpcogout, '@@@ FIN FORSTAT @@@ WITH LCSAVE,NO', lcsave, no) ; nextline ;
1405           END ;
1406 $OPTIONS compile = true $
1407       END (* FORSTAT *) ;
1408 
1409 
1410 $OPTIONS page $
1411 
1412 (* ************************************ GOTOSTAT ****************************** *)
1413 
1414     PROCEDURE gotostat ;
1415 
1416 (* C .INSTRUCTION COMPILED IS    GOTO   <INTEGER> .
1417    .ALL DECLARED LABELS ARE   IN LABTAB   FROM  1  TO  CLABIX
1418    .IF DECLARED LEVEL IS CURRENT LEVEL ,THEN IT IS A LOCAL GOTO
1419    (FORWARDS  IF  LABDEF=0 , BACKWARDS OTHERWISE).
1420    IF NOT,  RETURNS  IN A PREVIOUS  PROC, THEN IT IS NECESSARY TO CLOSE
1421    LOCAL LIVING FILES  ,AND TO GET THE OLD STACK FRAME.
1422    C *)
1423 (* E ERRORS DETECTED
1424    15: INTEGER EXPECTED
1425    167: UNDECLARED LABEL
1426    E *)
1427       LABEL
1428         20 ;                                      (* EXIT OF LOOP *)
1429       VAR
1430         it : integer ;
1431         refbox : refptr ;
1432       BEGIN                                       (* GOTOSTAT *)
1433 $OPTIONS compile = trace $
1434         IF stattrace > none THEN
1435           BEGIN
1436             write (mpcogout, '@@@ DEBUT GOTOSTAT @@@') ; nextline ;
1437           END ;
1438 $OPTIONS compile = true $
1439         insymbol ;
1440         IF (no # 2) OR (cl # 1) THEN              (* NOT AN INTEGER CSTE *)
1441           BEGIN
1442             error (15) ; skip (46) ;
1443           END ELSE
1444           BEGIN
1445                                                   (* SEARCHS IVAL  IN LABTAB *)
1446             FOR it := clabix DOWNTO 1 DO
1447               WITH labtab [it] DO
1448                 IF labval = ival THEN             (* LABEL FOUND *)
1449                   BEGIN
1450                     IF labbox <> NIL THEN
1451                       WITH labbox^ DO
1452                         BEGIN
1453                           refbox := references ;
1454                           IF refbox <> NIL THEN BEGIN
1455                               IF refbox^.refnbr = maxref THEN BEGIN
1456                                   new (refbox) ;
1457                                   WITH refbox^ DO
1458                                     BEGIN
1459                                       nextref := references ;
1460                                       references := refbox ;
1461                                       refnbr := 1
1462                                     END ;
1463                                 END
1464                               ELSE
1465                                 WITH refbox^ DO
1466                                   refnbr := refnbr + 1 ;
1467                               WITH refbox^ DO
1468                                 WITH refs [refnbr] DO BEGIN
1469                                     filen := symbolfile ;
1470                                     place := ic ;
1471                                     IF lablev <> level THEN
1472                                       linen := -symbolline
1473                                     ELSE
1474                                       linen := symbolline ;
1475                                   END ;
1476                             END ;
1477                         END ;
1478                     IF lablev # level THEN
1479                       BEGIN                       (* GOTO EXIT *)
1480                                                   (* REMOVE  FRAMES *)
1481                         IF (lablev = 0) AND exportablecode THEN
1482                           BEGIN
1483                             IF NOT linktomain THEN
1484                               BEGIN
1485                                 linktomainplace := lkc ; lkc := lkc + bytesindword ;
1486                                 linktomain := true
1487                               END ;
1488                             genstand (prlink, linktomainplace DIV bytesinword, iepp1, tny) ;
1489                             IF labexit = 0 THEN
1490                               BEGIN
1491                                 labexit := lkc ; lkc := lkc + bytesindword
1492                               END ;
1493                             genstand (prlink, labexit DIV bytesinword, iepp2, tny) ;
1494                             genstand (pr0, gotoexitextplace, itsp3, tn) ;
1495                           END
1496                         ELSE
1497                           BEGIN
1498                             loadbase (lablev) ;
1499                             IF currentpr # pr1 THEN genstand (currentpr, 0, iepp1, tn) ;
1500                             freebloc (currentbloc) ;
1501                             IF labexit = 0 THEN   (* FIRST OCCUR *)
1502                               BEGIN
1503                                 labexit := lkc ; lkc := lkc + bytesindword ;
1504                               END ;
1505                             genstand (prlink, labexit DIV bytesinword, iepp2, tny) ;
1506                             genstand (pr0, gotoexitplace, itsp3, tn) ;
1507                           END ;
1508                                                   (* EXIT LOOP *) GOTO 20 ;
1509                       END (* GOTO EXT *) ELSE
1510                       BEGIN                       (* LOCAL GOTO *)
1511                         IF labdef # 0 THEN        (* ALREADY DEFINED *)
1512                           genstand (nreg, (labdef - cb) DIV bytesinword, itra, tic) ELSE
1513                           BEGIN                   (* NOT YET RESOLVED *)
1514                             enterundlab (labch1) ;
1515                             genstand (nreg, 0, itra, tic) ;
1516                           END (* NOT YET RESOLV. *) ;
1517                                                   (* EXIT LOOP *) GOTO 20 ;
1518                       END (* LOCAL GOTO,IF,IF,WITH,FOR *) ;
1519                   END ;
1520                                                   (* AT THIS POINT, *)
1521                                                   (* NOT FOUND INTEGER IN LABTAB *)
1522             error (167) ;
1523 20 :                                              (* EXIT LOOP FOR *)
1524             insymbol ;
1525             IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1526           END (* INTEGER FOUND *) ;
1527 $OPTIONS compile = trace $
1528         IF stattrace > low THEN
1529           BEGIN
1530             write (mpcogout, '@@@ FIN GOTOSTAT @@@ WITH NO', no : 4) ; nextline ;
1531           END ;
1532 $OPTIONS compile = true $
1533       END (* GOTOSTAT *) ;
1534 
1535 
1536 $OPTIONS page $
1537 
1538 (* ************************************ IFSTAT ******************************** *)
1539 
1540     PROCEDURE ifstat ;
1541 
1542 (* C .COMPILATION OF   IF   <EXPRESSION>  THEN   <STATE>
1543    IF   <EXPRESSION>  THEN   <STATE>  ELSE  <STATE>
1544    .GENJUMP GENERATES A  BRANCH  USING THE SETTING OF CONDITION CODES
1545    C *)
1546 (* E ERRORS DETECTED
1547    6 : BOOLEAN EXPRESSION EXPECTED
1548    52 : "THEN" EXPECTED
1549    E *)
1550       LABEL
1551         20,                                       (* CALL OF STATEMENT  AFTER THEN *)
1552         30 ;                                      (* SKIP    STATEMENT  AFTER THEN *)
1553       VAR
1554         locthen, locelse : integer ;
1555       BEGIN                                       (* IFSTAT *)
1556 $OPTIONS compile = trace $
1557         IF stattrace > none THEN
1558           BEGIN
1559             write (mpcogout, '@@@ DEBUT IFSTAT @@@') ; nextline ;
1560           END ;
1561 $OPTIONS compile = true $
1562         locthen := 0 ;                            (* DEFAULT MEANS NO INSER TO DO *)
1563         freeallregisters ;
1564         insymbol ; expression ;
1565         IF gattr.typtr # NIL THEN
1566           BEGIN
1567             IF gattr.typtr # boolptr THEN
1568               error (6) ELSE
1569               genjump (locthen, 0) ;
1570           END ;
1571         IF no # 24 (* THEN *) THEN
1572           BEGIN
1573             IF gattr.typtr # NIL THEN error (52) ;
1574             skip (24) ;
1575             IF no # 24 THEN
1576               BEGIN
1577                 IF gattr.typtr = NIL THEN error (52) ;
1578                 IF errcl [no] = endsy THEN
1579                   GOTO 30 ELSE
1580                   GOTO 20 ;
1581               END ;
1582           END (* NO#24 *) ;
1583         insymbol ;
1584         IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1585 20 :
1586         freeallregisters ;
1587         push_lab_pdl ; statement ; pop_lab_pdl ;
1588 30 :
1589         IF no = 25 (* ELSE *) THEN
1590           BEGIN
1591             locelse := indfich ; genstand (nreg, 0, itra, tic) ;
1592             IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1593           END ;
1594         IF locthen # 0 THEN
1595           inser (cb, locthen) ;
1596         IF no = 25 (* ELSE *) THEN
1597           BEGIN
1598             insymbol ;
1599             freeallregisters ;
1600             push_lab_pdl ; statement ; pop_lab_pdl ;
1601             inser (cb, locelse) ;
1602             IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1603           END ;
1604 $OPTIONS compile = trace $
1605         IF stattrace > low THEN
1606           BEGIN
1607             write (mpcogout, '@@@ FIN IFSTAT @@@ WITH NO', no : 4) ; nextline ;
1608           END ;
1609 $OPTIONS compile = true $
1610       END (* IFSTAT *) ;
1611 
1612 
1613 $OPTIONS page $
1614 
1615 (* ************************************ CASESTAT ****************************** *)
1616 
1617     PROCEDURE casestat ;
1618 
1619 (* C .ANALYSIS AND  CODE GENERATION  FOR THE  STATEMENT    <CASE>
1620    .GENERATED CODE IS THE FOLLOWING
1621    ********************
1622    *                  *
1623    *  SELECTOR IN RA  *
1624    ***              ***
1625    TRA   SWITCH
1626    ***              ***
1627    *                  *    FOR MIN, MIN+2
1628    E1 *   STATEMENT_1    *
1629    *                  *
1630    *  TRA   END       *
1631    ................
1632    *                  *    FOR MAX
1633    EN *   STATEMENT_N    *
1634    *
1635    *  TRA   END
1636    ********************
1637    *                  *
1638    SWITCH *  RA TO ZERO POINT*
1639    *  RA IN [MIN..MAX]*
1640    *  TRA  VECTOR[RA] *
1641    *                  *
1642    ********************
1643    VECTOR *    TRA E1        *   MINSELECT
1644    *    TRA END       *   MIN+1
1645    *    TRA E1        *   MIN+2
1646    *    .......       *   .....
1647    *    TRA EN        *   MAXSELECT
1648    ********************
1649    END.
1650    C *)
1651 (* E ERRORS DETECTED
1652    1: SCALAR OR NUMERIC EXPECTED AS SELECTOR
1653    7  ":" EXPECTED
1654    8: "OF" EXPECTED
1655    13  "END" EXPECTED
1656    14 : ";" EXPECTED
1657    20  "," EXPECTED
1658    23  "CASE LABEL" EXPECTED
1659    60: "OR" NOT ALLOWED AS MONADIC OPERATOR
1660    61 : ILLEGAL BEGINNING SYMBOL FOR A STATEMENT
1661    103  IDENTIFIER IS NOT OF APPROPRIATE CLASS
1662    104  UNDECLARED IDENTIFIER
1663    105  SIGN NOT ALLOWED HERE
1664    147  TYPE CONFLICT  WITH THE CASE SELECTOR
1665    148  CASE VECTOR TRANSFER TOO LARGE
1666    156  DUPLICATE CASE LABEL
1667    304  VALUE OUT OF BOUNDS
1668    E *)
1669       LABEL
1670         1, (* EXIT WHILE *)                       (* INSERTION OF A NEW LABEL BOX *)
1671         2,                                        (* SKIP HERE IF DUPLICATE CASE LABEL *)
1672         3,
1673         10 ;                                      (* EXIT PROC BEFORE ALL THE "DISPOSE" *)
1674       TYPE
1675         ptcas = @ reccas ;
1676         reccas = RECORD
1677           next : ptcas ;                          (* LINK IN GROWING ORDER THESE BOXES *)
1678           cslab : integer ;                       (* SELECTING CASE LABEL  VALUE *)
1679           addr : integer ;                        (* "CB" VALUE OF FIRST INSTR. *)
1680                                                   (* FOR THIS STATEMENT *)
1681         END ;
1682                                                   (* SUCH A BOX IS BUILD *)
1683                                                   (* FOR  EACH CASE LABEL *)
1684         ptend = @ recend ;
1685         recend = RECORD
1686           succ : ptend ;                          (* REVERSE LINK *)
1687           indf : integer ;                        (* PLACE WHERE AN INSERTION OF *)
1688                                                   (* EXIT ADDRESS MUST BE MADE *)
1689         END ;
1690       VAR
1691         seltype, labtype, generic : ctp ;
1692         locitra, locminexit, locmaxexit, loctabl, otherwiseplace : integer ;
1693         firstetiq, firstcase, minus, sign, stoploop, noterr, errintab, ierr, otherwise : boolean ;
1694         headcase, ptboxcur, ptlast, workpt, savept : ptcas ;
1695         ptchnend, pttetend, savept2 : ptend ;
1696         lastgen, longtabl, maxselect, minselect, valselect : integer ;
1697       BEGIN                                       (* CASESTAT *)
1698 $OPTIONS compile = trace $
1699         IF stattrace > none THEN
1700           BEGIN
1701             write (mpcogout, '@@@ DEBUT CASESTAT @@@') ; nextline ;
1702           END ;
1703 $OPTIONS compile = true $
1704         otherwise := false ;
1705         seltype := NIL ; locitra := 0 ;
1706         headcase := NIL ; pttetend := NIL ;
1707         minselect := 0 ; maxselect := 0 ;
1708                                                   (* *SELECTOR ANALYSIS *)
1709         freeallregisters ;
1710         insymbol ; expression ;
1711         WITH gattr DO
1712           BEGIN
1713             IF typtr # NIL THEN
1714               IF typtr@.form IN [numeric, scalar] THEN
1715                 BEGIN
1716                   transfer (gattr, inacc) ; freebloc (gattr.ldregbloc) ;
1717                   seltype := typtr ;
1718                   locitra := indfich ; genstand (nreg, 0, itra, tic) ;
1719                 END ELSE
1720                 error (1) ;
1721           END (* WITH GATTR *) ;
1722                                                   (* *)
1723                                                   (* <OF> *)
1724                                                   (* *)
1725         IF no # 27 THEN
1726           BEGIN
1727             IF gattr.typtr # NIL THEN error (8) ;
1728             skip (27) ;
1729             IF no # 27 THEN
1730               IF gattr.typtr = NIL THEN error (8) ;
1731           END ELSE
1732           insymbol ;
1733         noterr := true ;
1734                                                   (* *)
1735                                                   (* ** MAIN LOOP  ON STATEMENT  BLOCKS *)
1736                                                   (* *)
1737         firstcase := true ;
1738         REPEAT
1739           IF no = 7 (*  + - OR *) THEN
1740             BEGIN
1741               minus := cl = 2 ;                   (* - *)
1742               IF cl = 3 THEN error (60) ;
1743               insymbol ; sign := true ;
1744             END ELSE
1745             BEGIN
1746               minus := false ; sign := false ;
1747             END ;
1748           IF (no <= 2) THEN                       (* CAN BE  A CASE LABEL *)
1749             BEGIN
1750               stoploop := false ;
1751               firstetiq := true ;
1752               REPEAT                              (* LOOP  ON LABEL(S)   FOR ONE  BLOCK *)
1753                 labtype := NIL ;
1754                 IF no = 1 (* ID *) THEN
1755                   BEGIN
1756                     search ;
1757                     IF ctptr = NIL THEN
1758                       BEGIN
1759                         IF firstetiq AND (NOT firstcase) THEN
1760                           IF envstandard > stdsol THEN
1761                             IF (aval = usednames [6]) THEN (* OTHERWISE !! *)
1762                               BEGIN
1763                                 otherwise := true ;
1764                                 otherwiseplace := cb ;
1765                                 REPEAT
1766                                   insymbol ;
1767                                   freeallregisters ;
1768 3 :                               push_lab_pdl ; statement ; pop_lab_pdl ;
1769                                   IF errcl [no] = begsy THEN
1770                                     BEGIN
1771                                       error (14) ; GOTO 3 ;
1772                                     END ;
1773                                   IF no = 25 (* ELSE *) THEN
1774                                     BEGIN
1775                                       error (61) ; insymbol ; GOTO 3 ;
1776                                     END ;
1777                                 UNTIL no <> 16 (* ; *) ;
1778                                 IF no <> 22 THEN BEGIN
1779                                     error (13) ;
1780                                     GOTO 10 ;
1781                                   END ;
1782                                 new (ptchnend) ; IF ptchnend = NIL THEN heaperror ; (* EXIT COMP *)
1783                                 ptchnend@.succ := pttetend ; pttetend := ptchnend ;
1784                                 ptchnend@.indf := indfich ;
1785                                 genstand (nreg, 0, itra, tic) ; (* EXIT OF CASE *)
1786                                 GOTO 10 ;
1787                               END ;
1788                         error (104) ; insymbol ; skip (46) ;
1789                       END ELSE
1790                       BEGIN
1791                         IF symbolmap THEN nameisref (ctptr, symbolfile, symbolline) ;
1792                         WITH ctptr@ DO
1793                           IF klass # konst THEN
1794                             BEGIN
1795                               IF klass >= vars THEN stoploop := true ;
1796                               error (103) ; insymbol ; skip (46) ;
1797                             END (* # KONST *) ELSE
1798                             BEGIN                 (* KONST *)
1799                               IF contype # NIL THEN
1800                                 BEGIN
1801                                   labtype := contype ;
1802                                   IF minus THEN valselect := -values
1803                                   ELSE valselect := values ;
1804                                 END ;
1805                             END (* KONST *) ;
1806                       END
1807                   END (* NO=1 *) ELSE
1808                   IF no = 2 (* CSTE *) THEN
1809                     BEGIN
1810                       CASE cl OF
1811                         1 : labtype := intptr ;
1812                         2, 3 : error (1) ;
1813                         4 : labtype := charptr ;
1814                       END ;
1815                       IF labtype # NIL THEN
1816                         IF minus THEN valselect := -ival ELSE valselect := ival ;
1817                     END (* NO=2 *) ELSE
1818                     BEGIN
1819                       error (23) ;
1820                     END ;
1821                                                   (* TYPE  COMPATIBILTY *)
1822                 IF labtype # NIL THEN
1823                   BEGIN
1824                     IF seltype = NIL THEN
1825                       seltype := labtype ELSE
1826                       BEGIN
1827                         compatbin (seltype, labtype, generic) ;
1828                         IF (generic = NIL) OR (generic = realptr) THEN
1829                           BEGIN
1830                             error (147) ; labtype := NIL ;
1831                           END ELSE
1832                           BEGIN
1833                             IF generic@.form # numeric THEN
1834                               IF sign THEN error (105) ;
1835                             checkminmax (valselect, seltype, 304) ;
1836                           END (* GENERIC NOT NIL *) ;
1837                       END (* SELTYPE#NIL *) ;
1838                   END (* LABTYPE #NIL *) ;
1839                 IF labtype # NIL THEN
1840                   BEGIN
1841                     noterr := true ;
1842                     ptboxcur := headcase ; ptlast := NIL ;
1843                     WHILE ptboxcur # NIL DO
1844                       BEGIN
1845                         IF ptboxcur@.cslab >= valselect THEN
1846                           BEGIN
1847                             IF ptboxcur@.cslab = valselect THEN
1848                               BEGIN error (156) ; GOTO 2 ;
1849                               END ;
1850                             GOTO 1 ;              (*  EXIT LOOP *)
1851                           END ;
1852                         ptlast := ptboxcur ;
1853                         ptboxcur := ptboxcur@.next ;
1854                       END ;
1855                                                   (* HERE  MAXSELECT MUST BE CHANGED. *)
1856                                                   (* BOXES ARE LINKED VIA  NEXT *)
1857                                                   (* IN GROWTHING ORDER *)
1858                                                   (* HEADCASE   POINTS  THE SMALLEST *)
1859                     maxselect := valselect ;
1860 1 :                                               (* CREATES A NEW LABEL BOX *)
1861                     new (workpt) ; IF workpt = NIL THEN heaperror ; (* EXIT COMP *)
1862                     WITH workpt@ DO
1863                       BEGIN
1864                         next := ptboxcur ; cslab := valselect ; addr := cb ;
1865                       END ;
1866                     IF ptlast = NIL THEN          (* BOX =NEW BEGINNING OF LIST *)
1867                       BEGIN
1868                         headcase := workpt ; minselect := valselect ;
1869                       END ELSE
1870                       ptlast@.next := workpt ;
1871                   END (* LABTYPE#NIL,CREATES THEN A NEW LABEL BOX *) ;
1872 2 :                                               (* SKIP HERE IF DUPLICATE LABEL *)
1873                 IF NOT stoploop THEN
1874                   BEGIN
1875                     insymbol ;
1876                     IF no = 19 (* : *) THEN
1877                       stoploop := true ELSE
1878                       BEGIN
1879                         IF no = 15 THEN           (* , *)
1880                           BEGIN
1881                             insymbol ;
1882                             IF no = 7 THEN
1883                               BEGIN
1884                                 minus := cl = 2 ; sign := true ;
1885                                 IF cl = 3 THEN error (60) ;
1886                                 insymbol ;
1887                               END ELSE
1888                               BEGIN
1889                                 minus := false ; sign := false ;
1890                               END ;
1891                           END (* NO=15 *) ELSE
1892                           error (20) ;
1893                         ierr := false ;
1894                         WHILE NOT (no IN [1, 2, 19]) AND (errcl [no] = irrelsy) DO
1895                           BEGIN
1896                             insymbol ; ierr := true ;
1897                           END ;
1898                         IF ierr THEN error (7) ;
1899                         IF no > 2 THEN stoploop := true ;
1900                       END (* NO#19 *) ;
1901                   END (* NOT STOPLOOP *) ;
1902                 firstetiq := false ;
1903               UNTIL stoploop ;
1904               IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1905                                                   (* *)
1906                                                   (* STATEMENT  BLOCK *)
1907                                                   (* *)
1908               IF (no = 19) OR (errcl [no] = begsy) THEN
1909                 BEGIN
1910                   IF no = 19 THEN insymbol ;
1911                   freeallregisters ;
1912                                                   (* ********* *)
1913                   push_lab_pdl ; statement ; pop_lab_pdl ;
1914                                                   (* ********* *)
1915                 END ;
1916               new (ptchnend) ; IF ptchnend = NIL THEN heaperror ; (* EXIT COMP *)
1917               ptchnend@.succ := pttetend ; pttetend := ptchnend ;
1918               ptchnend@.indf := indfich ;
1919               genstand (nreg, 0, itra, tic) ;     (* EXIT OF CASE *)
1920               IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
1921             END (* NO <=2  CAN BE A CASE LABEL *) ELSE
1922             BEGIN
1923               IF noterr THEN
1924                 BEGIN
1925                   error (23) ; noterr := false ;
1926                 END ;
1927               skip (46) ;
1928               IF no # 22 THEN
1929                 IF errcl [no] = begsy THEN
1930                   statement ELSE
1931                   insymbol ;
1932             END (* NO >2  THEN ERROR *) ;
1933           IF no = 16 (* ; *) THEN
1934             insymbol ELSE
1935             IF (no # 22) (* END *) AND noterr THEN
1936               BEGIN
1937                 error (13) ; GOTO 10 ;            (* EXIT LOOP *)
1938               END ;
1939           firstcase := false ;
1940         UNTIL no = 22 ;                           (* END *)
1941 10 :
1942         longtabl := maxselect - minselect + 1 ;
1943         IF longtabl > (maxfich - indfich) DIV bytesinhword THEN
1944           BEGIN
1945             error (148) ;
1946             errintab := true ; locmaxexit := 0 ;
1947           END ELSE
1948           errintab := false ;
1949                                                   (* *)
1950                                                   (* CODE GENERATION *)
1951                                                   (* *)
1952         IF mapswitch THEN statement_begins (true) ;
1953         IF locitra # 0 THEN
1954           inser (cb, locitra) ;
1955         IF inxcheck THEN
1956           IF seltype # NIL THEN
1957             checkbnds (caserrcode, ra, seltype) ;
1958                                                   (* ZERO POINT *)
1959         IF minselect # 0 THEN
1960           gencstecode (minselect, isba) ;
1961                                                   (* NOOP OR STOP IF   < MIN , >MAX *)
1962                                                   (* *)
1963         genstand (nreg, 0, icmpa, tdl) ;
1964         IF otherwise THEN
1965           genstand (nreg, (otherwiseplace - cb) DIV bytesinword, itmi, tic) ELSE
1966           BEGIN
1967             locminexit := indfich ; genstand (nreg, 0, itmi, tic) ;
1968           END ;
1969         IF NOT errintab THEN
1970           BEGIN
1971             genstand (nreg, longtabl - 1, icmpa, tdl) ;
1972             IF otherwise THEN
1973               genstand (nreg, (otherwiseplace - cb) DIV bytesinword, itpnz, tic) ELSE
1974               BEGIN
1975                 locmaxexit := indfich ; genstand (nreg, 0, itpnz, tic) ;
1976               END ;
1977           END ;
1978                                                   (* HERE  EXP  IS IN  MIN..MAX *)
1979         loctabl := indfich ; genstand (nreg, 0, iepp3, tic) ; (* POINTS FIRST SWITCH *)
1980         genstand (pr3, 0, itra, tal) ;
1981         inser (cb, loctabl) ;
1982         lastgen := minselect - 1 ;
1983         WHILE headcase # NIL DO
1984           BEGIN
1985             IF NOT errintab THEN
1986               WHILE headcase@.cslab # lastgen + 1 DO
1987                 BEGIN
1988                                                   (* NO OP  THEN EXIT OR STOP *)
1989                   IF otherwise THEN
1990                     genstand (nreg, (otherwiseplace - cb) DIV bytesinword, itra, tic) ELSE
1991                     genstand (nreg, longtabl + minselect - 1 - lastgen, itra, tic) ;
1992                   lastgen := lastgen + 1 ;
1993                 END ;
1994                                                   (* HERE EQUALITY, *)
1995                                                   (* THEN GOTO SUITABLE STATEMENT BLOCK *)
1996             IF NOT errintab THEN
1997               genstand (nreg, (headcase@.addr - cb) DIV bytesinword, itra, tic) ;
1998             lastgen := headcase@.cslab ;
1999             savept := headcase ; headcase := headcase@.next ;
2000             savept := NIL ;
2001           END (* WHILE *) ;
2002         IF NOT otherwise THEN
2003           BEGIN
2004             inser (cb, locminexit) ;
2005             IF locmaxexit # 0 THEN
2006               inser (cb, locmaxexit) ;
2007             IF inxcheck THEN
2008               BEGIN IF minselect # 0 THEN gencstecode (minselect, iada) ;
2009                 genexceptcode (caserrcode, ra) ;
2010               END ;
2011           END ;
2012                                                   (* INSER  ALL  ENDING JUMPS *)
2013         ptchnend := pttetend ;
2014         WHILE ptchnend # NIL DO
2015           BEGIN
2016             inser (cb, ptchnend@.indf) ; savept2 := ptchnend ;
2017             ptchnend := ptchnend@.succ ; savept2 := NIL ;
2018           END ;
2019         IF mapswitch THEN statement_ends (3) ;    (* "end" *)
2020         insymbol ;
2021 $OPTIONS compile = trace $
2022         IF stattrace > low THEN
2023           BEGIN
2024             write (mpcogout, '@@@ FIN CASESTAT @@@ WITH NO,CL:', no : 4, cl : 4) ; nextline ;
2025           END ;
2026 $OPTIONS compile = true $
2027       END (* CASESTAT *) ;
2028 
2029 (* ************************************ STATEMENT ***************************** *)
2030 
2031     PROCEDURE statement ;
2032 
2033 (* C  EACH STATEMENT CAN BE PREFIXED BY A LABEL     INT:
2034    AFTER LABEL ANALYSIS, SPLITSTAT [NO] IS A SWITCH TO SEVERAL PROCEDURES
2035    C *)
2036 
2037 (* E ERRORS DETECTED
2038    7: ":" EXPECTED
2039    42 Sol procedure not in  PASCAL
2040    44 Sol procedure not yet implemented
2041    45 Extended pascal not allowed at this level
2042    61: ILLEGAL BEGINNING SYMBOL FOR A STATEMENT
2043    86: THIS FUNCTION MUST BE ASSIGNED IN HIS BLOCK
2044    103: IDENTIFIER IS NOT OF APPROPRIATE CLASS
2045    104: IDENTIFIER NOT DECLARED
2046    150: ASSIGNMENT TO STANDARD FUNCTION NOT ALLOWED
2047    165: MULTIDEFINED LABEL
2048    167: LABEL IS NOT DECLARED
2049    196: ASSIGNMENT NOT ALLOWED FOR THIS VARIABLE
2050    306: LABEL MUST HAVE AT MOST 4 DIGITS
2051    E *)
2052       LABEL
2053         1 ;                                       (* EXIT FOR WHEN LABEL FOUND *)
2054       VAR
2055         it : integer ;
2056       BEGIN                                       (* STATEMENT *)
2057 $OPTIONS compile = trace $
2058         IF stattrace > none THEN
2059           BEGIN
2060             write (mpcogout, '@@@ DEBUT STATEMENT @@@ WITH NO', no : 4) ; nextline ;
2061           END ;
2062 $OPTIONS compile = true $
2063                                                   (* FIRST CHECK FOR LABEL *)
2064         IF (no = 2) THEN                          (* CSTE  *)
2065           IF (cl = 1) THEN                        (* "   INTEGER *)
2066             BEGIN
2067               IF ival > 9999 THEN error (306) ;
2068               FOR it := clabix DOWNTO 1 DO
2069                 WITH labtab [it] DO
2070                   IF labval = ival THEN           (* FOUND *)
2071                     BEGIN
2072                       IF labbox <> NIL THEN
2073                         WITH labbox^ DO
2074                           BEGIN
2075                             deffile := symbolfile ; defline := symbolline ; locinbytes := ic ;
2076                             WITH lab_pdl_top^ DO
2077                               BEGIN
2078                                 next_in_block := first_in_block ;
2079                                 first_in_block := labbox ;
2080                               END ;
2081                           END ;
2082                       IF lablev <> level THEN
2083                         error (167) ELSE
2084                         IF labdef <> 0 THEN       (* MULTIDEFINED *)
2085                           error (165) ELSE
2086                           BEGIN                   (* FIRST OCCUR ==> RESOLVE IT *)
2087                             labdef := cb ;        (* PLACE IN CODE FOR CURRENT PROCEDURE *)
2088                             IF labch1 # 0 THEN
2089                               BEGIN               (* USED BEFORE DEFINITION *)
2090                                 inserundlab (cb, labch1) ;
2091                                 labch1 := 0 ;     (* FLAG RESOLVED *)
2092                               END (* USED *) ;
2093                             IF labexit <> 0 THEN
2094                               BEGIN               (* USED IN GOTO EXIT *)
2095                                 genstand (pr6, pr4depw, iepp4, tny) ;
2096                                                   (* RESET PR4 DEL. BY UNWINDER OPER. *)
2097                               END (* USED IN GOTO EXIT *) ;
2098                           END (* FIRST OCCUR,NO ERR *) ;
2099                                                   (* EXIT LOOP *) GOTO 1 ;
2100                     END (* LABEL FOUND,WITH,FOR *) ;
2101                                                   (* HERE LABEL NOT FOUND *)
2102               error (167) ;
2103 1 :           insymbol ;
2104               IF no = 19 (* : *) THEN
2105                 insymbol ELSE
2106                 BEGIN
2107                   error (7) ; skip (46) ;
2108                 END ;
2109             END (* CL=1, NO=2 *) ;
2110         freeallregisters ;
2111 
2112         IF splitstat [no] <> 1 THEN
2113           IF mapswitch THEN statement_begins (true) ;
2114 
2115         CASE splitstat [no] OF
2116           (* NOOP    *) 1 : (* ENDSY,IRRELSY *) ;
2117                                                   (* IDENTIF. *) 2 :
2118             BEGIN
2119               search ;
2120               IF ctptr = NIL THEN
2121                 BEGIN
2122                   error (104) ; ctptr := undecptr ;
2123                 END ;
2124               WITH ctptr@ DO
2125                 IF klass <= konst THEN
2126                   error (103) ELSE
2127                                                   (* VARS PROC FIELD *)
2128                   IF klass = proc THEN            (* PROC OR FUNCT *)
2129                     BEGIN
2130                       IF proctype = ctptr THEN    (* not a function *)
2131                         BEGIN                     (* PROC *)
2132                           IF symbolmap THEN
2133                             nameisref (ctptr, symbolfile, symbolline) ;
2134                           insymbol ;
2135                           CASE ploc OF
2136                             notpredef : BEGIN     (* PROGRAMMER PROC *)
2137                                 passparams (0) ;  (* NOT USED FOR A PROC *)
2138                               END ;
2139                             instdpure :
2140                               CASE segsize OF
2141                                 0, 1, 2, 3 : getput (segsize) ; (* INCLUDE RESET POINTER *)
2142                                 4, 5 : newir (segsize - 4) ;
2143                                 6, 7 : readir (segsize - 6) ;
2144                                 8, 9, 10 : writeir (segsize - 8) ;
2145                                 11, 12 : pckunpck (segsize - 11) ;
2146                               END ;
2147                             instdcompiler : insapp (segsize) ;
2148                             instdsol :
2149                               BEGIN
2150                                 IF envstandard = stdpure THEN
2151                                   error (42) ;
2152                                 CASE segsize OF
2153                                   0, 1, 2, 3, 4, 5, 6 : getput (segsize + 4) ;
2154                                   7 : writeir (3) ;
2155                                   8 : argvstat ;
2156                                   9 : stopstat ;
2157                                 END ;
2158                               END (* INSTDSOL *) ;
2159                             instdextend :
2160                               BEGIN
2161                                 IF envstandard <> stdextend THEN error (45) ;
2162                                 CASE segsize OF
2163                                   2 : mvcir (0) ;
2164                                   0, 1 : dateandtime (segsize) ;
2165                                   3 : insert_string ;
2166                                   4 : delete_string ;
2167                                 END ;
2168                               END (* INSTDEXTEND *) ;
2169 
2170                           END (* case PLOC *) ;
2171                         END (*  PROCEDURE *) ELSE
2172                         BEGIN                     (* FUNCTION IDENTIFIER ASSIGNMENT *)
2173                           IF ploc <> notpredef THEN
2174                             BEGIN
2175                               IF symbolmap THEN
2176                                 nameisref (ctptr, symbolfile, -symbolline) ;
2177                               error (150) ; skip (46) ;
2178                             END ELSE
2179                             BEGIN
2180                               genstand (nreg, level - proclevel - 1, ilda, tdl) ;
2181                               genstand (pr0, functionvaluesetplace, itsp3, tn) ;
2182                               procisassigned := true ;
2183 
2184                               IF NOT procinscope THEN error (86) ;
2185 
2186 
2187                               assign ;
2188 
2189 
2190                             END (* NO ERRORS FOR FUNCT. ID *) ;
2191                         END (* FUNCT. IDENTIFIER *) ;
2192                     END (* KLASS=PROC *) ELSE
2193                     BEGIN                         (* VARS OR FIELD *)
2194                       IF klass = vars THEN
2195                         BEGIN
2196                                                   (* VISUSED SET IN ADDRESSVAR *)
2197                           IF visreadonly THEN error (196) ;
2198                           visset := true ;
2199                         END (* VARS *) ;
2200 
2201 
2202                       assign ;
2203 
2204 
2205                     END (* VARS OR FIELD *) ;
2206               IF mapswitch THEN statement_ends (symbolindex - sttindex) ;
2207             END (*  IDENT., SPLITSTAT=2 *) ;
2208           3 (* BEGIN  *) : compstat ;
2209           4 (* IF     *) : ifstat ;
2210           5 (* CASE   *) : casestat ;
2211           6 (* REPEAT *) : repeatstat ;
2212           7 (* WHILE  *) : whilestat ;
2213           8 (* FOR    *) : forstat ;
2214           9 (* GOTO   *) : gotostat ;
2215           10 (* WITH   *) : withstat ;
2216         END (* CASE SPLITSTAT *) ;
2217 
2218 (* FREEALLREGISTERS MUST BE CALLED HERE, BECAUSE IT MAY GENERATE CODE
2219    WHICH IS LOGICALLY RELATED TO CODE GENERATED DURING STATEMENT.
2220    THIS IS DUE TO NEW STACK EXTENSION MECHANISM, USED FOR SOME TEMPORARY
2221    VARIABLES, IN STRING EXPRESSIONS EVALUATION *)
2222 
2223         freeallregisters ;
2224         IF errcl [no] = irrelsy THEN
2225           BEGIN
2226             error (61) ; skip (46) ;
2227           END ;
2228 $OPTIONS compile = trace $
2229         IF stattrace > low THEN
2230           BEGIN
2231             write (mpcogout, '@@@ FIN STATEMENT @@@ WITH NO=', no : 4) ; nextline ;
2232           END ;
2233 $OPTIONS compile = true $
2234       END (* STATEMENT *) ;
2235 
2236 
2237 (* END OF STATE MODULE ******************************************* *) BEGIN
2238     END.