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 PROGRAM modvariable ;
  19 
  20 $OPTIONS switch trace := true ; switch security := true ; t + $
  21 
  22 
  23     $IMPORT
  24       'STATE (pascal) ' :
  25         addressvar,
  26         checkbnds,
  27         choicerarq,
  28         enterlcst,
  29         enterllcst,
  30         enterundlab,
  31         freebloc,
  32         gencstecode,
  33         genexceptcode,
  34         getpr,
  35         inbounds,
  36         loadadr,
  37         loadbase,
  38         newbloc,
  39         oldnewstor,
  40         raisused,
  41         regenere,
  42         sauvereg,
  43         stack_extension,
  44         transfer,
  45         variab,
  46         variabctptr ;
  47       'CONTEXTTABLE (pascal) ' :
  48         areconformeq,
  49         checkminmax,
  50         compatbin,
  51         conformantdim,
  52         findminmax,
  53         legalconfarrsubstitution,
  54         packedsize ;
  55       'RACINE (pascal) ' :
  56         error,
  57         insymbol,
  58         nameisref,
  59         nextline,
  60         recadre,
  61         skip,
  62         sup ;
  63       'optimized_procedures (alm)' :
  64         search,
  65         srchrec ;
  66       'MODATTR(pascal)' :
  67         convreal,
  68         freeattr,
  69         initattrvarbl,
  70         is_pl1_varying_char,
  71         isstring,
  72         printattr,
  73         varissimple ;
  74       'EXPR (pascal) ' :
  75         expression ;
  76       'GENOPER (pascal)' :
  77         check_dynamic_string_length ;
  78       'GENERE (pascal) ' :
  79         gendesca,
  80         inser,
  81         genstand,
  82         geneism ;
  83       'RACINE (pascal) ' :
  84         alfaptr,
  85         charptr,
  86         ctptr,
  87         envstandard,
  88         interactive,
  89         intptr,
  90         level,
  91         mpcogout,
  92         no,
  93         realptr,
  94         string_ptr,
  95         symbolfile,
  96         symbolline,
  97         symbolmap,
  98         textfilectp ;
  99       'GENERE (pascal) ' :
 100         cb,
 101         indfich,
 102         mfari1,
 103         mfari2,
 104         usednameaddr ;
 105       'STATE (pascal) ' :
 106         arrayboundsctp,
 107         asscheck,
 108         currentbloc,
 109         currentpr,
 110         currwithlist,
 111         gattr,
 112         inxcheck,
 113         modif,
 114         opaq,
 115         prinst,
 116         regcharge,
 117         stattrace,
 118         withvariable ;
 119     $
 120 
 121 
 122     $EXPORT
 123       init_desc_address,
 124       passparams,
 125       variable
 126 
 127     $
 128 $INCLUDE 'CONSTTYPE' $
 129 
 130 
 131     VAR
 132 
 133 (* REDEFINE IMPORTED VARIABLES FROM RACINE   *)
 134 
 135       alfaptr : ctp ;
 136       charptr : ctp ;
 137       ctptr : ctp ;
 138       envstandard : stdkind ;
 139       interactive : boolean ;
 140       intptr : ctp ;
 141       level : levrange ;
 142       mpcogout : text ;
 143       no : integer ;
 144       realptr : ctp ;
 145       string_ptr : ctp ;
 146       symbolfile : integer ;
 147       symbolline : integer ;
 148       symbolmap : boolean ;
 149       textfilectp : ctp ;
 150 
 151 (* REDEFINE IMPORTED VARIABLES FROM GENERE   *)
 152 
 153       cb : integer ;
 154       indfich : integer ;
 155       mfari1 : zari ;
 156       mfari2 : zari ;
 157       usednameaddr : ctp ;
 158 
 159 (* REDEFINE IMPORTED VARIABLES FROM STATE    *)
 160 
 161       arrayboundsctp : ctp ;
 162       asscheck : boolean ;
 163       currentbloc : regpt ;
 164       currentpr : preg ;
 165       currwithlist : withreflist ;
 166       gattr : attr ;
 167       inxcheck : boolean ;
 168       modif : ARRAY [nxreg..rq] OF tag ;          (* GIVES FOR A REGISTER R ITS TAG TR *)
 169       opaq : ARRAY [typeofop, ra..reaq] OF istand ;
 170       prinst : ARRAY [typepr, pr1..pr6] OF istand ;
 171       regcharge : statearray ;
 172       stattrace : levtrace ;
 173       variabctptr : ctp ;
 174       withvariable : boolean ;
 175 
 176 (* REDEFINE IMPORTED PROCEDURES FROM STATE *)
 177 
 178     PROCEDURE addressvar (fctp : ctp ; VAR fattr : attr ; modif : boolean) ; EXTERNAL ;
 179     PROCEDURE checkbnds (errcode : integer ; freg : register ; fctp : ctp) ; EXTERNAL ;
 180     PROCEDURE choicerarq ; EXTERNAL ;
 181     PROCEDURE enterlcst (VAR fval : setarray ; VAR fboxpt : lcstpt) ; EXTERNAL ;
 182     PROCEDURE enterllcst (VAR fval : setarray ; VAR fboxpt : llcstpt) ; EXTERNAL ;
 183     PROCEDURE enterundlab (VAR fundinx : integer) ; EXTERNAL ;
 184     PROCEDURE freebloc (VAR fbtofree : regpt) ; EXTERNAL ;
 185     PROCEDURE gencstecode (farg : integer ; finst : istand) ; EXTERNAL ;
 186     PROCEDURE genexceptcode (ferrcode : integer ; freg : register) ; EXTERNAL ;
 187     PROCEDURE getpr ; EXTERNAL ;
 188     FUNCTION inbounds (fval, fmin, fmax : integer) : boolean ; EXTERNAL ;
 189     PROCEDURE loadadr (VAR fattr : attr ; wantedpr : preg) ; EXTERNAL ;
 190     PROCEDURE loadbase (flev : integer) ; EXTERNAL ;
 191     PROCEDURE newbloc (freg : register) ; EXTERNAL ;
 192     FUNCTION oldnewstor (incrinbytes : integer) : integer ; EXTERNAL ;
 193     FUNCTION raisused : boolean ; EXTERNAL ;
 194     PROCEDURE regenere (oldbloc : regpt) ; EXTERNAL ;
 195     PROCEDURE sauvereg (freg : register ; fload : boolean) ; EXTERNAL ;
 196     PROCEDURE stack_extension ; EXTERNAL ;
 197     PROCEDURE transfer (VAR fattr : attr ; inwhat : destination) ; EXTERNAL ;
 198     PROCEDURE variab (fvarset : boolean) ; EXTERNAL ;
 199 
 200 (* REDEFINE IMPORTED PROCEDURES FROM CONTEXTTABLE *)
 201 
 202     FUNCTION areconformeq (f1, f2 : ctp) : boolean ; EXTERNAL ;
 203     PROCEDURE checkminmax (fvalu : integer ; fctp : ctp ; ferrnum : integer) ; EXTERNAL ;
 204     PROCEDURE compatbin (typleft, typright : ctp ; VAR fgeneric : ctp) ; EXTERNAL ;
 205     FUNCTION conformantdim (ffound : ctp) : boolean ; EXTERNAL ;
 206     PROCEDURE findminmax (fctp : ctp ; VAR fmin, fmax : integer) ; EXTERNAL ;
 207     FUNCTION legalconfarrsubstitution (ffound, fdecl : ctp) : boolean ; EXTERNAL ;
 208     FUNCTION packedsize (fctp : ctp) : integer ; EXTERNAL ;
 209 
 210 (* REDEFINE IMPORTED PROCEDURES FROM RACINE *)
 211 
 212     PROCEDURE error (errno : integer) ; EXTERNAL ;
 213     PROCEDURE insymbol ; EXTERNAL ;
 214     PROCEDURE nameisref (p : ctp ; f, l : integer) ; EXTERNAL ;
 215     PROCEDURE nextline ; EXTERNAL ;
 216     FUNCTION recadre (fnum, fmod : integer) : integer ; EXTERNAL ;
 217     PROCEDURE search ; EXTERNAL ;
 218     PROCEDURE skip (nosym : integer) ; EXTERNAL ;
 219     PROCEDURE srchrec (fdebsrch : ctp) ; EXTERNAL ;
 220     FUNCTION sup (fval1, fval2 : integer) : integer ; EXTERNAL ;
 221 
 222 (* REDFINE IMPORTED PROCEDURES FROM MODATTR *)
 223 
 224     FUNCTION is_pl1_varying_char (VAR typeptr : ctp) : boolean ; EXTERNAL ;
 225     PROCEDURE convreal (VAR fattr : attr) ; EXTERNAL ;
 226     PROCEDURE initattrvarbl (VAR fattr : attr) ; EXTERNAL ;
 227     PROCEDURE freeattr (VAR fattr : attr) ; EXTERNAL ;
 228     FUNCTION isstring (VAR fattr : attr) : boolean ; EXTERNAL ;
 229     PROCEDURE printattr (VAR fattr : attr) ; EXTERNAL ;
 230     FUNCTION varissimple (VAR fattr : attr) : boolean ; EXTERNAL ;
 231 
 232 (* REDEFINE IMPORTED PROCEDURES FROM EXPRESSION *)
 233 
 234     PROCEDURE expression ; EXTERNAL ;
 235 
 236 (* REDEFINE IMPORTED PROEDURES FORM GENOPER *)
 237 
 238     PROCEDURE check_dynamic_string_length (VAR fattr : attr) ; EXTERNAL ;
 239 
 240 (* REDEFINE IMPORTED PROCEDURES FROM GENERE     *)
 241 
 242     PROCEDURE gendesca (fareg : preg ; fadr, fcn : integer ; fta : lgcar ;
 243       fn : integer ; frlgth : mreg) ; EXTERNAL ;
 244     PROCEDURE genstand (fpr : preg ; fadr : integer ; fcode : istand ; ftg : tag) ; EXTERNAL ;
 245     PROCEDURE inser (fcb : integer ; fplace : integer) ; EXTERNAL ;
 246     PROCEDURE geneism (fcode : ieism ; ffield : integer ; fbits : zptr) ; EXTERNAL ;
 247 
 248 
 249 $OPTIONS page $
 250 
 251 (* **************************    INIT_DESC_ADDRESS     ********* *)
 252 
 253     PROCEDURE init_desc_address (fctptr : ctp ; VAR fattr : attr) ;
 254 
 255 (* C A conformant array or schema variable described by FATTR is input.
 256    As output, a pointer register on dopevector (and his box)
 257    FATTR points real variable
 258    C *)
 259 
 260       VAR
 261         ldisp : integer ;
 262         locpt : ctp ;
 263         lreg : preg ;
 264         lbloc : regpt ;
 265 
 266 
 267       BEGIN                                       (* INIT_DESC_ADDRESS *)
 268 
 269         IF fattr.descreg = nreg THEN
 270           BEGIN
 271 $OPTIONS compile = trace $
 272             IF stattrace = high THEN
 273               BEGIN
 274                 write (mpcogout, '^^^ Debut de INIT_DESC_ADDRESS ^^^ ') ; nextline ;
 275               END ;
 276 $OPTIONS compile = true $
 277 
 278             locpt := fattr.nameaddr ;
 279             ldisp := 1 ;
 280             IF locpt <> NIL THEN
 281               IF locpt^.vtype <> NIL THEN
 282                 IF locpt^.vtype^.father_schema <> NIL THEN ldisp := 0 ;
 283                                                   (* Return DOPEVECTOR BASE *)
 284             getpr ;
 285             genstand (fattr.basereg, fctptr^.vdescaddr DIV bytesinword, prinst [epp, currentpr], tny) ;
 286             genstand (currentpr, ldisp (* Header *), prinst [epp, currentpr], tn) ;
 287             lreg := currentpr ;
 288             lbloc := currentbloc ;
 289 
 290             loadadr (fattr, nreg) ;               (* Returns   CURRENTPR  and CURRENTBLOC  *)
 291 
 292             initattrvarbl (fattr) ;
 293             WITH fattr DO
 294               BEGIN
 295                 access := pointee ; basereg := currentpr ; basebloc := currentbloc ;
 296                 nameaddr := locpt ;
 297                 descreg := lreg ; descbloc := lbloc ;
 298               END ;
 299 
 300           END ;
 301 
 302 $OPTIONS compile = trace $
 303         IF stattrace = high THEN
 304           BEGIN
 305             write (mpcogout, '^^^ Fin   de INIT_DESC_ADDRESS ^^^') ; nextline ;
 306           END ;
 307 $OPTIONS compile = true $
 308 
 309       END (* INIT_DESC_ADDRESS *) ;
 310 
 311 $OPTIONS page $
 312 
 313 (* *************************** VARIABLE ****************************** *)
 314 
 315     PROCEDURE variable (fvarset : boolean) ;
 316 
 317 (* C
 318    BUILD  A GATTR   FOR    ELEMENT ARRAY       NO=11   [
 319    POINTED ITEM          =18   ^
 320    RECORD FIELD          =17   .
 321    FILE ELEMENT          =18   ^
 322 
 323    FIRST CALL  ADDRESSVAR
 324    C *)
 325 
 326 (* E  ERRORS DETECTED
 327    2: IDENTIFIER EXPECTED
 328    12: "]" EXPECTED
 329    139: INDEX TYPE NOT COMPATIBLE with DECLARATION
 330    140: RECORDS EXPECTED
 331    141: FILES or POINTER EXPECTED
 332    142: ARRAYS  EXPECTED
 333    152: NO  SUCH FIELD in THIS RECORD
 334    302: INDEX OUT OF BOUNDS
 335    E *)
 336 
 337       VAR
 338         loc1, loc2 : integer ;
 339         string_base : preg ; string_disp : integer ;
 340         loaded_reg : register ;
 341         lattr : attr ;
 342         lerr, smallelem, isconform, totransfer, stoprepeat : boolean ;
 343         locvariabctptr : ctp ;
 344         nextdimisconform, done_with_index : boolean ;
 345         arraytype, generic : ctp ;
 346         destused : destination ;
 347         regused : register ;
 348 $OPTIONS compile = trace $
 349         newattr : boolean ;
 350 $OPTIONS compile = true $
 351         subarraysize, pointzero, twopower, lmin, lmax : integer ;
 352         lbase : preg ;
 353         lcomp : istand ;
 354         oldline, oldfile : integer ;
 355         lp, oldptr : ctp ;
 356         checkismade : boolean ;
 357         locdopevectordisp : integer ;
 358         previouswasarrow, savewithflag : boolean ;
 359         it : integer ;
 360         refs : RECORD
 361           nbr : integer ;
 362           ref : ARRAY [1..maxfield] OF
 363           RECORD
 364             symbp : ctp ;
 365             rfile, rline : integer
 366           END
 367         END ;
 368 
 369 
 370 (* *************************************************** ENTERREF **************************** *)
 371 
 372       PROCEDURE enterref ;
 373 
 374         BEGIN
 375           IF oldptr <> NIL THEN
 376             IF refs.nbr < maxfield THEN
 377               BEGIN
 378                 refs.nbr := refs.nbr + 1 ;
 379                 WITH refs.ref [refs.nbr] DO
 380                   BEGIN
 381                     symbp := oldptr ;
 382                     rfile := symbolfile ;
 383                     rline := symbolline ;
 384                   END ;
 385                 oldptr := NIL ;
 386               END
 387         END ;
 388 
 389       BEGIN                                       (* VARIABLE *)
 390 $OPTIONS compile = trace $
 391         IF stattrace > none THEN
 392           BEGIN
 393             write (mpcogout, '^^^ DEBUT VARIABLE ^^^') ;
 394             nextline ;
 395           END ;
 396         newattr := false ;
 397 $OPTIONS compile = true $
 398 
 399         locvariabctptr := ctptr ;
 400         addressvar (ctptr, lattr, fvarset) ;
 401         locdopevectordisp := 0 ;
 402 
 403 
 404 
 405         oldfile := symbolfile ; oldline := symbolline ; oldptr := ctptr ;
 406         insymbol ;
 407         previouswasarrow := false ;
 408         refs.nbr := 0 ;
 409         WHILE no IN [11, 17, 18] DO               (* [  .  ^ *)
 410           BEGIN
 411 $OPTIONS compile = trace $
 412             newattr := true ;
 413 $OPTIONS compile = true $
 414             IF no = 11 THEN                       (* ARRAY'S  ELEMENT *)
 415               BEGIN
 416                 savewithflag := withvariable ;
 417                 withvariable := false ;
 418                 done_with_index := false ;
 419                 IF lattr.typtr <> NIL THEN
 420                   WITH lattr.typtr^ DO
 421                     IF (father_schema = string_ptr) AND (no = 11) THEN
 422                       BEGIN                       (* STRING INDEX. SPECIAL SEQUENCE *)
 423                         done_with_index := true ;
 424                         IF asscheck THEN
 425                           check_dynamic_string_length (lattr) ;
 426                         IF varissimple (lattr) THEN
 427                           BEGIN
 428                             string_base := lattr.basereg ; string_disp := lattr.dplmt DIV bytesinword ;
 429                           END ELSE BEGIN
 430                             loadadr (lattr, nreg) ;
 431                             string_base := currentpr ; string_disp := 0 ;
 432                             WITH lattr DO
 433                               BEGIN
 434                                 access := pointee ; basereg := currentpr ; basebloc := currentbloc ;
 435                                 dplmt := 0 ;
 436                               END
 437                           END ;
 438                         lerr := false ;
 439                         insymbol ; expression ;
 440                         compatbin (intptr, gattr.typtr, generic) ;
 441                         IF (generic = NIL) OR (generic = realptr) THEN
 442                           BEGIN
 443                             lerr := true ; error (280) ;
 444                           END ;
 445                         IF no <> 12 THEN
 446                           BEGIN lerr := true ; error (12) END
 447                         ELSE insymbol ;
 448                         IF NOT lerr THEN
 449                           BEGIN
 450                             WITH gattr DO
 451                               CASE kind OF
 452                                 varbl : BEGIN
 453                                     IF raisused THEN
 454                                       BEGIN
 455                                         loaded_reg := rq ; sauvereg (rq, false) ;
 456                                         transfer (gattr, inq) ;
 457                                       END
 458                                     ELSE BEGIN
 459                                         loaded_reg := ra ;
 460                                         transfer (gattr, inacc) ;
 461                                       END ;
 462                                   END ;
 463                                 sval : BEGIN
 464                                     IF raisused THEN
 465                                       BEGIN
 466                                         loaded_reg := rq ; sauvereg (rq, false) ;
 467                                       END ELSE
 468                                       loaded_reg := ra ;
 469                                     gencstecode (val, opaq [load, loaded_reg]) ;
 470                                   END ;
 471                                 lval : BEGIN
 472                                     loaded_reg := ldreg ;
 473                                     IF asscheck THEN
 474                                       genstand (nreg, 0, opaq [add, loaded_reg], tdl) ; (* TO SET INDIC *)
 475                                   END ;
 476                               END ;
 477                             freeattr (gattr) ;
 478                             IF asscheck THEN
 479                               BEGIN
 480                                 loc2 := indfich ; genstand (nreg, 0, itmoz, tic) ;
 481                                 genstand (string_base, string_disp, opaq [cmp, loaded_reg], tn) ;
 482                                 loc1 := indfich ; genstand (nreg, 0, itmoz, tic) ;
 483                                 inser (cb, loc2) ;
 484                                 genexceptcode (bad_string_index, loaded_reg) ;
 485                                 inser (cb, loc1) ;
 486                               END ;
 487                             WITH lattr DO
 488                               BEGIN
 489                                 IF basereg IN [prstatic, prlink, pr6] THEN
 490                                   BEGIN
 491                                     getpr ; genstand (basereg, 0, prinst [epp, currentpr], tn) ;
 492                                     basereg := currentpr ; basebloc := currentbloc ;
 493                                   END ;
 494                                 genstand (basereg, 0, ia9bd, modif [loaded_reg]) ;
 495                                 dplmt := dplmt + 3 ;
 496                                 nameaddr := NIL ;
 497                                 pckd := true ;
 498                               END ;
 499                           END ;
 500                         lattr.typtr := charptr ;
 501                       END ;
 502 
 503                 IF NOT done_with_index THEN
 504                   BEGIN
 505                     REPEAT                        (* LOOP ON EACH DIMENSION *)
 506                       WITH lattr DO               (* DESCRIBE  PREVIOUS *)
 507                         BEGIN
 508                           IF typtr <> NIL THEN
 509                             BEGIN                 (* NO PREV. FATAL ERROR *)
 510                               IF typtr^.form <> arrays THEN
 511                                 BEGIN
 512                                   typtr := NIL ;
 513                                   error (142) ;
 514                                 END (* ERR *) ELSE
 515                                 WITH typtr^ DO
 516                                   IF aeltype <> NIL THEN
 517                                     BEGIN         (* ARRAYS *)
 518                                       IF conformantdim (typtr) THEN
 519                                         BEGIN
 520                                           IF symbolmap THEN
 521                                             BEGIN
 522                                               nameisref (pthigh, oldfile, oldline) ;
 523                                               nameisref (ptlow, oldfile, oldline) ;
 524                                             END ;
 525                                           IF lattr.descreg = nreg THEN
 526                                             BEGIN
 527                                               lp := typtr ;
 528                                               WHILE conformantdim (lp^.aeltype) DO
 529                                                 BEGIN
 530                                                   locdopevectordisp := locdopevectordisp + 3 ;
 531                                                   lp := lp^.aeltype
 532                                                 END ;
 533                                               init_desc_address (locvariabctptr, lattr) ;
 534                                             END ;
 535                                         END ;
 536                                       smallelem := cadrage < bytesinword ;
 537                                       pckd := smallelem OR ((aeltype^.form = pointer)
 538                                         AND pack) ;
 539                                       isconform := conformant ;
 540                                       nextdimisconform := conformantdim (aeltype) ;
 541                                     END (* ARRAYS *) ;
 542                             END (* TYPTR <>nil *) ;
 543                           arraytype := typtr ;
 544                         END (* with LATTR *) ;
 545                                                   (* *)
 546                                                   (* ANALYSIS  FOR CURRENT *)
 547                                                   (* INDEX EXPRESSION *)
 548                                                   (* (* *)
 549 
 550                       insymbol ; expression ;
 551 
 552                       IF gattr.typtr <> NIL THEN
 553                         IF arraytype <> NIL THEN
 554                           WITH gattr, arraytype^ DO
 555                             BEGIN
 556                               compatbin (arraytype^.inxtype, typtr, generic) ;
 557                               IF (generic = NIL) OR (generic = realptr) THEN
 558                                 error (139) ELSE
 559                                 BEGIN             (* TYPES COMPAT *)
 560 
 561 $OPTIONS compile = trace $
 562                                   IF stattrace = high THEN
 563                                     BEGIN
 564                                       write (mpcogout, '&&& Variable. Break point 3.') ; nextline ;
 565                                       write (mpcogout, '    SMALLELEM =', smallelem : 8, ' PCKD = ', pckd : 8,
 566                                         ' ISCONFORM = ', isconform : 8) ; nextline ;
 567                                       write (mpcogout, ' GATTR Follows:') ; nextline ;
 568                                       printattr (gattr) ;
 569                                       write (mpcogout, ' LATTR Follows:') ; nextline ;
 570                                       printattr (lattr) ;
 571                                       write (mpcogout, '&&& Variable. Break point 3 .Fin.') ; nextline ;
 572                                     END ;
 573 $OPTIONS compile = true $
 574                                   IF isconform THEN
 575                                     BEGIN
 576                                       IF gattr.kind = sval THEN
 577                                         checkminmax (gattr.val, arraytype^.inxtype, 302) ;
 578                                       transfer (gattr, inq) ;
 579                                       checkismade := false ; destused := inq ; regused := rq ;
 580                                     END (* ISCONFORM *) ELSE
 581                                     BEGIN         (* STANDARD ARRAY *)
 582                                       subarraysize := subsize ;
 583                                       twopower := opt2 ;
 584                                       pointzero := lattr.dplmt - lo * subarraysize ;
 585                                                   (* FIND DESTINATION REGISTER *)
 586                                       IF twopower >= 2 (* SIZE 4,8,16... *) THEN
 587                                         CASE kind OF
 588                                           lval :
 589                                             regused := ldreg ;
 590                                           sval, lcond, varbl :
 591                                             IF raisused THEN
 592                                               regused := rq ELSE
 593                                               regused := ra ;
 594                                         END (* CASE KIND,TWOPOWER>=2 *) ELSE
 595                                         regused := rq ; (* MULTIPLICAND in RQ *)
 596                                       IF regused = ra THEN
 597                                         destused := inacc ELSE
 598                                         destused := inq ;
 599                                     END (* STANDARD ARRAYS *) ;
 600                                   IF (kind = sval) THEN
 601                                     BEGIN
 602                                       arrayboundsctp^.nmin := lo ;
 603                                       arrayboundsctp^.nmax := hi ;
 604                                       checkminmax (val, arrayboundsctp, 302) ;
 605                                       checkismade := true ;
 606                                       IF lattr.pckd THEN
 607                                         transfer (gattr, destused) ;
 608                                     END ELSE
 609                                     checkismade := false ;
 610                                   IF kind = sval THEN (* ONLY STANDARD *)
 611                                     BEGIN
 612                                       lattr.dplmt := pointzero + val * subarraysize ;
 613                                     END (* SVAL *) ELSE
 614                                     BEGIN         (* NOT SVAL *)
 615                                       IF inxcheck THEN
 616                                         BEGIN
 617                                           transfer (gattr, destused) ;
 618                                           IF isconform THEN
 619                                             BEGIN
 620                                               regenere (lattr.descbloc) ;
 621                                               genstand (lattr.descreg, locdopevectordisp, icmpq, tn) ;
 622                                               lmin := indfich ; genstand (nreg, 0, itmi, tic) ;
 623                                               genstand (lattr.descreg, locdopevectordisp + 1, icmpq, tn) ;
 624                                             END ELSE
 625                                             IF NOT checkismade THEN
 626                                               BEGIN
 627                                                 lcomp := opaq [cmp, regused] ;
 628                                                 gencstecode (lo, lcomp) ;
 629                                                 lmin := indfich ;
 630                                                 genstand (nreg, 0, itmi, tic) ; (* ERR if NEG ON *)
 631                                                 gencstecode (hi, lcomp) ;
 632                                               END (* NOT CONF *) ;
 633                                                   (* COMMON  SECTION *)
 634                                           IF NOT checkismade THEN
 635                                             BEGIN
 636                                               lmax := indfich ;
 637                                               genstand (nreg, 0, itmoz, tic) ; (* OK if <= *)
 638                                               inser (cb, lmin) ; genexceptcode (inxerrcode, ldreg) ;
 639                                               inser (cb, lmax) ;
 640                                             END ;
 641                                         END (* INXCHECK *) ELSE
 642                                         IF NOT isconform THEN
 643                                           BEGIN   (* NOT INXCHECKS *)
 644                                             totransfer := true ;
 645                                             IF kind = varbl THEN
 646                                               IF vlev <> 0 THEN
 647                                                 IF subarraysize = bytesinword THEN
 648                                                   IF varissimple (gattr) THEN
 649                                                     IF lattr.inxmem = 0 THEN
 650                                                       BEGIN
 651                                                         totransfer := false ;
 652                                                         lattr.dplmt := pointzero ;
 653                                                         lattr.inxmem := dplmt ;
 654                                                         lattr.inxmemrw := false ; (* READ-ONLY *)
 655                                                       END ;
 656                                             IF totransfer THEN
 657                                               transfer (gattr, destused) ;
 658                                           END (* NOT INXCHECK *) ;
 659                                     END (* NOT SVAL *) ;
 660                                                   (* NOW INDEX IS in REGUSED , *)
 661                                                   (* EXCEPT   SVAL   endED *)
 662                                                   (* VARBL  INXMEMRW F   endED *)
 663 
 664 $OPTIONS compile = trace $
 665                                   IF stattrace = high THEN
 666                                     BEGIN
 667                                       write (mpcogout, '&&& Variable. Break point 2.') ; nextline ;
 668                                       write (mpcogout, '    REGUSED =', ord (regused) : 4,
 669                                         '    DESTUSED  =', ord (destused) : 4) ; nextline ;
 670 
 671                                       write (mpcogout, ' GATTR Follows:') ; nextline ;
 672                                       printattr (gattr) ;
 673                                       write (mpcogout, ' LATTR Follows:') ; nextline ;
 674                                       printattr (lattr) ;
 675                                       write (mpcogout, '&&& Variable. Break point 2 .Fin.') ; nextline ;
 676                                     END ;
 677 $OPTIONS compile = true $
 678                                   IF kind = lval THEN (* COMPUTE DISP *)
 679                                     BEGIN
 680                                       IF isconform THEN
 681                                         BEGIN
 682                                                   (* Zero point correction *)
 683                                           regenere (lattr.descbloc) ;
 684                                           genstand (lattr.descreg, locdopevectordisp, isbq, tn) ;
 685                                           sauvereg (ra, false) ;
 686                                           genstand (lattr.descreg, locdopevectordisp + 2, impy, tn) ;
 687                                           IF NOT nextdimisconform THEN
 688                                             BEGIN
 689                                               freebloc (lattr.descbloc) ;
 690                                               lattr.descreg := nreg ;
 691                                             END ;
 692 
 693                                           regenere (lattr.basebloc) ;
 694                                           IF pack THEN genstand (lattr.basereg, 0, iabd, tql)
 695                                           ELSE genstand (lattr.basereg, 0, iawd, tql) ;
 696                                           freebloc (gattr.ldregbloc) ;
 697                                           regused := nreg ;
 698 
 699                                           locdopevectordisp := locdopevectordisp - 3 ; (* Next dim *)
 700 
 701                                         END ELSE
 702                                         BEGIN     (* STANDARD *)
 703                                                   (* COMMON PART *)
 704                                                   (* ZERO POINT CORRECTION *)
 705                                           IF lo <> 0 THEN
 706                                             BEGIN
 707                                               IF (NOT smallelem) AND
 708                                                 inbounds (pointzero, -twoto16, twoto16 - 1) THEN
 709                                                 lattr.dplmt := pointzero ELSE
 710                                                 gencstecode (lo, opaq [sub, regused]) ;
 711                                             END (* LO<>0 *) ;
 712                                           IF NOT smallelem THEN
 713                                             BEGIN (* WORD DISP *)
 714                                               IF twopower > 2 (*   8 16 32 .. *) THEN
 715                                                 genstand (nreg, twopower - 2, opaq [shiftl, regused], tn) ELSE
 716                                                   (* TWOPOWER =2    NO-OP ; *)
 717                                                   (* 0,1  IMPOSSIBLE  HERE *)
 718                                                 IF twopower < 0 THEN
 719                                                   BEGIN
 720                                                     transfer (gattr, inq) ;
 721                                                     sauvereg (ra, false) ;
 722                                                     genstand (nreg, subarraysize DIV bytesinword, impy, tdl) ;
 723                                                     regused := rq ;
 724                                                   END (* TWOPOWER < 0 *) ;
 725                                             END (* WORD DISP *) ELSE
 726                                             BEGIN (* PACKED *)
 727                                                   (* ADD BYTES DISP TO A PR *)
 728                                               loadadr (lattr, nreg) ;
 729                                               WITH lattr DO (* CAUTION NESTED ATTR *)
 730                                                 BEGIN
 731                                                   basereg := currentpr ; basebloc := currentbloc ;
 732                                                   dplmt := 0 ;
 733                                                   inxreg := nxreg ; inxbloc := NIL ;
 734                                                   inxmem := 0 ; inxmemrw := true ;
 735                                                   itsdplmt := 0 ; access := pointee ;
 736                                                 END (* NESTED *) ;
 737                                                   (* RA RQ BECOMES "BYTES" DISP *)
 738                                               IF twopower > 0 THEN
 739                                                 genstand (nreg, twopower, opaq [shiftl, regused], tn) ELSE
 740                                                   (* NO-OP  FOR BYTE *)
 741                                                 IF twopower < 0 THEN
 742                                                   BEGIN
 743                                                     transfer (gattr, inq) ;
 744                                                     sauvereg (ra, false) ;
 745                                                     gencstecode (subarraysize, impy) ;
 746                                                     regused := rq ;
 747                                                   END (* < 0 *) ;
 748                                               IF size >= twoto15 THEN
 749                                                 BEGIN
 750                                                   IF regused = ra THEN
 751                                                     BEGIN
 752                                                       sauvereg (rq, false) ;
 753                                                       regused := rq ; (* SEE A9BD LATER *)
 754                                                       genstand (nreg, 2, ilrl, tn) ;
 755                                                     END (* RA *) ELSE
 756                                                     BEGIN
 757                                                       sauvereg (ra, false) ;
 758                                                       genstand (nreg, 34, ills, tn) ;
 759                                                     END ;
 760                                                   genstand (nreg, 34, iqrl, tn) ;
 761                                                   (* NOW  A=WORD  DISP. *)
 762                                                   (*     Q=BYTES DISP. *)
 763                                                   genstand (currentpr, 0, iawd, tal) ;
 764                                                 END (* LONG *) ;
 765                                               genstand (currentpr, 0, ia9bd, modif [regused]) ;
 766                                               freebloc (ldregbloc) ;
 767                                               regused := nreg ;
 768                                             END (* PACKED *) ;
 769                                         END (* STANDARD ARRAY *) ;
 770 
 771 $OPTIONS compile = trace $
 772                                       IF stattrace = high THEN
 773                                         BEGIN
 774                                           write (mpcogout, '&&& Variable. Break point 1.') ; nextline ;
 775                                           write (mpcogout, '    REGUSED =', ord (regused) : 4,
 776                                             '    DESTUSED  =', ord (destused) : 4) ; nextline ;
 777 
 778                                           write (mpcogout, ' GATTR Follows:') ; nextline ;
 779                                           printattr (gattr) ;
 780                                           write (mpcogout, ' LATTR Follows:') ; nextline ;
 781                                           printattr (lattr) ;
 782                                           write (mpcogout, '&&& Variable. Break point 1 .Fin.') ; nextline ;
 783                                         END ;
 784 $OPTIONS compile = true $
 785                                       IF regused <> nreg THEN
 786                                         WITH lattr DO (* CAUTION   NESTED ATTR *)
 787                                           BEGIN
 788                                             IF inxreg = nxreg THEN
 789                                               BEGIN
 790                                                 inxreg := regused ; (* BITS  18..35 *)
 791                                                 inxbloc := gattr.ldregbloc ;
 792                                               END (* NXREG *) ELSE
 793                                               IF inxreg = regused THEN
 794                                                 BEGIN (* NECESSARY  SAVED *)
 795                                                   IF inxmem = 0 THEN
 796                                                     BEGIN
 797                                                       inxmem := inxbloc^.saveplace ;
 798                                                     END (* INXMEM=0 *) ELSE
 799                                                     BEGIN (* <>0 *)
 800                                                   (* ADD SAVED OLD INDEX AT NEW INDEX *)
 801                                                       genstand (pr6, inxbloc^.saveplace DIV bytesinword,
 802                                                         opaq [add, regused], tn) ;
 803                                                     END (* <>0 *) ;
 804                                                   freebloc (inxbloc) ;
 805                                                   inxbloc := gattr.ldregbloc ;
 806                                                 END (* NECESSARY SAVED *) ELSE
 807                                                   (* OLD INDEX IS OTHER  *)
 808                                                   (* REGISTER  A <==>Q *)
 809                                                 IF inxmem = 0 THEN
 810                                                   BEGIN
 811                                                     IF inxbloc^.saveplace <> 0 THEN
 812                                                       BEGIN
 813                                                         inxreg := regused ;
 814                                                         inxmem := inxbloc^.saveplace ;
 815                                                         freebloc (inxbloc) ;
 816                                                         inxbloc := gattr.ldregbloc ;
 817                                                       END ELSE
 818                                                       BEGIN (* OLD INDEX NOT SAVED *)
 819                                                         inxmem := oldnewstor (bytesinword) ;
 820                                                         genstand (pr6, inxmem DIV bytesinword, ista, tn) ;
 821                                                         IF inxreg = rq THEN
 822                                                           freebloc (gattr.ldregbloc) ELSE
 823                                                           BEGIN
 824                                                             freebloc (inxbloc) ; inxreg := rq ;
 825                                                             inxbloc := gattr.ldregbloc ;
 826                                                           END ;
 827                                                       END (* OLD INDEX NOT SAVED *) ;
 828                                                   END (* INXMEM=0 *) ELSE
 829                                                   BEGIN (* INXMEM <> 0 *)
 830                                                     IF inxbloc^.saveplace <> 0 THEN
 831                                                       BEGIN (* OLD SAVED *)
 832                                                         genstand (pr6, inxbloc^.saveplace DIV bytesinword,
 833                                                           opaq [add, regused], tn) ;
 834                                                         freebloc (inxbloc) ;
 835                                                         inxbloc := gattr.ldregbloc ;
 836                                                         inxreg := regused ;
 837                                                       END (* OLD SAVED *) ELSE
 838                                                       BEGIN (* OLD NOT SAVED *)
 839                                                         IF inxmemrw THEN
 840                                                           genstand (pr6, inxmem DIV bytesinword, iasa, tn) ELSE
 841                                                           BEGIN (* READ-ONLY STORAGE *)
 842                                                             genstand (pr6, inxmem DIV bytesinword, iada, tn) ;
 843                                                             inxmem := oldnewstor (bytesinword) ;
 844                                                             inxmemrw := true ;
 845                                                             genstand (pr6, inxmem DIV bytesinword, ista, tn) ;
 846                                                           END ;
 847                                                         IF regused = rq THEN
 848                                                           BEGIN
 849                                                             freebloc (inxbloc) ; inxreg := rq ;
 850                                                             inxbloc := gattr.ldregbloc ;
 851                                                           END ELSE
 852                                                           freebloc (gattr.ldregbloc) ;
 853                                                       END (* OLD NOT SAVED *) ;
 854                                                   END (* INXMEM<>0 *) ;
 855                                           END (* with LATTR ==>   with GATTR *) ;
 856                                     END (* GATTR.KIND=LVAL *) ;
 857                                 END (* TYPES COMPAT *) ;
 858 
 859                               lattr.typtr := aeltype ; (* GET NEXT DIM *)
 860 
 861                             END (* with GATTR,ARRAYTYPE^, NO TYPE ERROR *) ;
 862                       IF no = 15 (* , *) THEN
 863                         stoprepeat := false ELSE
 864                         IF no = 12 (* ] *) THEN
 865                           BEGIN
 866                             insymbol ; stoprepeat := no <> 11 ; (* [ *)
 867                           END ELSE
 868                           BEGIN
 869                             insymbol ;
 870                             error (12) ; stoprepeat := true ;
 871                           END ;
 872                     UNTIL stoprepeat ;
 873                   END ;
 874                 withvariable := savewithflag ;
 875                 previouswasarrow := false ;
 876               END (* NO=11 ARRAY ELEMENT *) ELSE
 877               IF no = 17 (* . RECORD FIELD *) THEN
 878                 BEGIN
 879                   IF symbolmap THEN
 880                     BEGIN
 881                       enterref ;
 882                       IF previouswasarrow THEN
 883                         BEGIN
 884                           FOR it := 1 TO refs.nbr DO
 885                             WITH refs.ref [it] DO
 886                               nameisref (symbp, rfile, rline) ;
 887                           refs.nbr := 0 ;
 888                         END
 889                     END ;
 890                   insymbol ;
 891                   oldfile := symbolfile ; oldline := symbolline ; oldptr := NIL ;
 892                   IF no <> 1 THEN                 (* NOT ID *)
 893                     BEGIN
 894                       error (2) ; lattr.typtr := NIL ;
 895                     END ELSE
 896                     WITH lattr DO
 897                       BEGIN
 898                         IF typtr <> NIL THEN
 899                           IF typtr^.form <> records THEN
 900                             BEGIN
 901                               error (140) ; typtr := NIL ;
 902                             END ELSE
 903                             BEGIN
 904                               srchrec (typtr^.fstfld) ;
 905                               IF ctptr = NIL THEN
 906                                 BEGIN
 907                                   error (152) ; typtr := NIL ;
 908                                 END ELSE
 909                                 BEGIN
 910                                   nameaddr := ctptr ;
 911                                   oldptr := ctptr ;
 912                                   WITH ctptr^ DO
 913                                     BEGIN
 914                                       dplmt := dplmt + fldaddr ;
 915                                       pckd := false ;
 916                                       IF typtr^.pack THEN
 917                                         IF (bytwidth < bytesinword) OR ((fldtype^.form = power) AND
 918                                           (bytwidth <= bytesindword)) THEN
 919                                           pckd := true ELSE
 920                                           IF fldtype^.form = pointer THEN
 921                                             pckd := true ;
 922                                       typtr := fldtype ;
 923                                       IF pckd THEN
 924                                         IF access = direct THEN
 925                                           access := pointee ;
 926                                     END (* with CTPTR, CTPTR<>nil *) ;
 927                                 END ;
 928                             END (* NO TYPE ERROR *) ;
 929                         insymbol ;
 930                       END (* with LATTR, NO=1 *) ;
 931                   previouswasarrow := false ;
 932                 END (* NO=17 *) ELSE
 933                 BEGIN (* NO=18 *)                 (* ^  FILE or POINTER *)
 934                   WITH lattr DO
 935                     IF typtr <> NIL THEN
 936                       IF typtr^.form = pointer THEN
 937                         BEGIN
 938                           totransfer := false ;
 939                           IF access = pointable THEN
 940                             totransfer := true ELSE
 941                             IF access = direct THEN
 942                               BEGIN
 943                                 IF (inxmem <> 0) OR (inxreg <> nxreg) THEN
 944                                   totransfer := true ;
 945                               END ELSE
 946                               IF access = pointee THEN
 947                                 IF pckd OR (inxmem <> 0) OR (inxreg <> nxreg) THEN
 948                                   totransfer := true ;
 949                           IF totransfer THEN
 950                             transfer (lattr, inpr) (* BECOMES POINTEE *) ELSE
 951                             BEGIN
 952                               itsdplmt := dplmt ; dplmt := 0 ; access := pointable ;
 953                             END ;
 954                           typtr := typtr^.eltype ;
 955                         END (* POINTER *) ELSE
 956                         IF typtr^.form = files THEN
 957                           BEGIN
 958                             IF interactive THEN
 959                               IF typtr = textfilectp THEN
 960                                 BEGIN
 961                                   IF basereg <> pr5 THEN
 962                                     BEGIN
 963                                       sauvereg (pr5, true) ;
 964                                       freebloc (basebloc) ;
 965                                       basebloc := currentbloc ;
 966                                     END ;
 967                                   genstand (basereg, itsdplmt DIV bytesinword, iepp5, tny) ;
 968                                   basereg := pr5 ;
 969                                   access := pointee ; itsdplmt := 0 ; dplmt := 0 ;
 970                                   genstand (pr0, checkbeforetextreferenceplace, itsp3, tn) ;
 971                                 END ;
 972                             dplmt := fdescsize ;
 973                             pckd := false ;
 974                             IF typtr^.pack THEN
 975                               IF packedsize (typtr^.feltype) < bytesinword THEN
 976                                 pckd := true ELSE
 977                                 IF typtr^.feltype^.form = pointer THEN
 978                                   pckd := true ;
 979                             typtr := typtr^.feltype ;
 980                             IF pckd THEN
 981                               IF access = direct THEN
 982                                 access := pointee ;
 983                           END (* FILES *) ELSE
 984                           BEGIN
 985                             error (141) ; typtr := NIL ;
 986                           END ;
 987                   insymbol ;
 988                   previouswasarrow := true ;
 989                 END (* NO=18 *) ;
 990           END (*  while  NO in [11,17,18] *) ;
 991         IF symbolmap THEN
 992           BEGIN
 993             enterref ;
 994             IF previouswasarrow THEN
 995               BEGIN
 996                 FOR it := 1 TO refs.nbr DO
 997                   WITH refs.ref [it] DO
 998                     nameisref (symbp, rfile, rline) ;
 999                 refs.nbr := 0 ;
1000               END
1001             ELSE
1002               FOR it := 1 TO refs.nbr DO
1003                 WITH refs.ref [it] DO
1004                   IF fvarset THEN nameisref (symbp, rfile, -rline)
1005                   ELSE nameisref (symbp, rfile, rline) ;
1006             IF withvariable THEN
1007               BEGIN
1008                 currwithlist.nbr := refs.nbr ;
1009                 FOR it := 1 TO refs.nbr DO
1010                   currwithlist.symbolp [it] := refs.ref [it].symbp ;
1011               END ;
1012           END ;
1013         gattr := lattr ;
1014 $OPTIONS compile = trace $
1015         IF stattrace > low THEN
1016           BEGIN
1017             IF (stattrace = high) AND newattr THEN
1018               printattr (gattr) ;
1019             write (mpcogout, '^^^ FIN VARIABLE with NO', no : 4) ; nextline ;
1020           END ;
1021 $OPTIONS compile = true $
1022       END (* VARIABLE *) ;
1023 
1024 $OPTIONS page $
1025     PROCEDURE passparams (fctplace : integer) ;
1026 
1027 (* C. CALLED IN ORDER  TO
1028    . ANALYSE  ACTUAL PARAMETERS  FOR  A  PROCEDURE, FUNCTION CALL
1029    . BUILD   ARGUMENT'S LIST
1030    * STANDARD HEADER
1031    * POINTERS  LIST   ON PARAMETERS
1032    * FOR A FUNCTION  ONE MORE "ITS" POINTING THE  PLACE TO BE
1033    ASSIGNED
1034    . FOR   ACTUAL  PROCEDURE(FUNCTION) PARAMETER   TWO   "ITS" ARE GIVEN
1035    *  THE  RIGHT ITS  IN LINKAGE SECTION
1036    *  THE COMPUTED DYNAMIC LINK
1037    . FOR   A CONFORMANT   ARRAY       FOUR ITEMS
1038    * "ITS"  ON  REAL ARRAY
1039    * LOW BOUND,  HIGHBOUND,  DIM SIZE IN WORDS
1040    FCTPLACE  IS  THE DISP IN CALLER FRAME WHERE RETURNED VALUE MUST BE PUT
1041    . CTPTR POINTS  THE BOX "PROC" OF THE CALLED PROCEDURE
1042    . FIRST INSYMBOL  ALREADY DONE
1043    C *)
1044 (* E ERRORS DETECTED
1045    4: ")" EXPECTED
1046    15: "," EXPECTED
1047    28: PREDEF PROC/FUNCT NOT ALLOWED HERE
1048    103: UNAPPROPRIATE CLASS FOR ID.
1049    104: UNDECLARED ID.
1050    126: NUMBER OF PARAMETERS  DOES  NOT AGREE WITH  DECLARATION
1051    127: ILLEGAL PARAMETER SUBSTITUTION
1052    128: PARAMETER CONFLICT IN FORMAL PROC.
1053    133: ILLEGAL CONFORMANT ARRAY SUBSTITUTION
1054    230 : EFFICTIVE PARAMETER PASSED BY VALUE CAOONT BE CONFORMANT ARRAY
1055    303: VALUE ASSIGNED OUT OF RANGE
1056    318: PARAMETER PROCEDURE PASSED TO AN EXTERNAL PROCEDURE MUST BE EXPORTABLE
1057    E *)
1058       LABEL
1059         2,
1060         1 ;                                       (* EXIT PROC WHEN FATAL ERROR *)
1061                                                   (* IS DETECTED *)
1062       VAR
1063         itisafunct, pisformal, pisext, paramisproc, paramisvar, ended, lerr : boolean ;
1064         procnameaddr, parmctp, foundtype, decltype, generic : ctp ;
1065         plevel, procplacew, nbparm, longlist, deplist, curritsw, currparmw, currparb : integer ;
1066         lbase : preg ;
1067         declsize, foundsize, ldisp, lmod, lpad, suplr : integer ;
1068         ltag, lftag, rgtag : tag ;
1069         lattr : attr ;
1070         lretpt : lcstpt ; llretpt : llcstpt ;
1071         prevdecltype : ctp ;
1072         temppt, tempact : ctp ;
1073         nbofdim : integer ;
1074         locdisp : integer ;
1075         prevfoundtype : ctp ;
1076         dvdispw : integer ;
1077         multiplier, lowbound, highbound : integer ;
1078         arrconfblockw : integer ;
1079         firstoflist : boolean ;
1080         wlength, alfalow, alfahigh : integer ;
1081         all_descriptors, pisimported : boolean ;
1082         procbox : ctp ;
1083         pr5bloc : regpt ;
1084         formal_length : integer ;
1085         done : boolean ;
1086         nbofparm : integer ; parm_attr : attr ;
1087         loaded_reg : register ;
1088 
1089 
1090 (* ************************************ LOADLINK < PASSPARAMS ***************** *)
1091 
1092       PROCEDURE loadlink (fpreg : preg ; fplev : levrange) ;
1093 
1094 (* C.LOAD  FPREG  WITH THE DYNAMIC LINK  SUITABLE.
1095    .THREE CASES
1096    *CURRENT  LEVEL=  CALLED-LEVEL
1097    CALL OF A SUBPROCEDURE    DYN-LINK = PR6 OF CALLER
1098    * OR      SEARCHS   PREVIOUS CALLER(S)  D-LINK
1099    .CAUTION     WHEN LEVEL IS N,  PROCLEVEL IS N-1
1100    C *)
1101         VAR
1102           linst : istand ;
1103           it : integer ;
1104         BEGIN
1105           linst := prinst [epp, fpreg] ;
1106           IF level = fplev THEN
1107             genstand (pr6, 0, linst, tn) ELSE
1108             BEGIN
1109               genstand (pr6, dlkdepw, linst, tny) ;
1110               FOR it := 1 TO level - fplev - 1 DO
1111                 genstand (fpreg, dlkdepw, linst, tny) ;
1112             END ;
1113         END (* LOADLINK *) ;
1114 
1115 
1116 (* ************************************ FCT COMPATLIST< PASSPARAMS ************ *)
1117 
1118       FUNCTION compatlist (declproc, foundproc : ctp) : boolean ;
1119 
1120 (* C .DECLPARM   POINTS  THE PROCEDURE BOX
1121    FOUNDPARM  POINTS  THE     "      "
1122    .RETURNS  TRUE  OR FALSE
1123    C *)
1124         VAR
1125           iscompat, lerr, lerrvarval : boolean ;
1126           declparm, foundparm : ctp ;
1127           decltype, foundtype : ctp ;
1128 
1129         FUNCTION both_are_string_param : boolean ;
1130 
1131 (* SAYS IF BOTH PARAMETERS ARE DECLARED " : STRING" *)
1132 
1133           BEGIN
1134             IF (decltype^.father_schema <> NIL) AND (decltype^.actual_parameter_list <> NIL)
1135               AND (decltype^.father_schema = foundtype^.father_schema)
1136               AND (foundtype^.actual_parameter_list <> NIL)
1137             THEN
1138               both_are_string_param :=
1139                 (decltype^.actual_parameter_list^.vkind = arraybound)
1140               AND (foundtype^.actual_parameter_list^.vkind = arraybound)
1141             ELSE both_are_string_param := false
1142           END ;
1143         BEGIN                                     (* COMPATLIST *)
1144 $OPTIONS compile = trace $
1145           IF stattrace > none THEN
1146             BEGIN
1147               write (mpcogout, '@@@ DEBUT COMPATLIST @@@') ; nextline ;
1148             END ;
1149 $OPTIONS compile = true $
1150           declparm := declproc@.formals ; foundparm := foundproc@.formals ;
1151           iscompat := true ; lerrvarval := false ;
1152           WHILE (declparm # NIL) AND iscompat DO
1153             BEGIN
1154               IF foundparm = NIL THEN
1155                 iscompat := false ELSE
1156                 BEGIN
1157                   IF declparm@.klass # foundparm@.klass THEN
1158                     iscompat := false ELSE
1159                     BEGIN
1160                       IF declparm@.klass = proc THEN
1161                         iscompat := compatlist (declparm, foundparm) ELSE
1162                         BEGIN
1163                           IF declparm@.varparam # foundparm@.varparam THEN
1164                             lerrvarval := true ;
1165                           decltype := declparm@.vtype ; lerr := false ;
1166                           foundtype := foundparm@.vtype ;
1167                           WHILE (decltype # foundtype) AND NOT lerr DO
1168                             BEGIN
1169                               lerr := true ;
1170                               IF decltype # NIL THEN
1171                                 IF foundtype # NIL THEN
1172                                   IF both_are_string_param THEN
1173                                     BEGIN
1174                                       decltype := foundtype ; (* TO STOP WHILE LOOP *)
1175                                       lerr := false (* SCHEMA OK *)
1176                                     END
1177                                   ELSE
1178                                     IF decltype@.form = arrays THEN
1179                                       IF foundtype@.form = arrays THEN
1180                                         IF decltype@.conformant THEN
1181                                           IF foundtype@.conformant THEN
1182                                             IF decltype@.inxtype = foundtype@.inxtype THEN
1183                                               IF decltype^.pack = foundtype^.pack THEN
1184                                                 BEGIN
1185                                                   lerr := false ;
1186                                                   decltype := decltype@.aeltype ;
1187                                                   foundtype := foundtype@.aeltype ;
1188                                                 END ; (* EQUIVALENT CONFORMANT SCHEMAS *)
1189                             END ;                 (* TYPES # AND NO ERR *)
1190                           iscompat := NOT (lerr OR lerrvarval) ;
1191                         END (* NOT PROC *) ;
1192                       declparm := declparm@.nxtel ; foundparm := foundparm@.nxtel ;
1193                     END (* SAME KLASS *) ;
1194                 END (* FOUNDPARM#NIL *) ;
1195             END (* WHILE *) ;
1196           IF (declparm = NIL) AND (foundparm # NIL) THEN iscompat := false ;
1197 
1198 (* NOW  CHEK IF IT IS TWO PROC OR TWO FUNCTIONS *)
1199           IF iscompat THEN
1200             IF declproc@.proctype # declproc THEN
1201               BEGIN
1202                 IF foundproc@.proctype = foundproc THEN
1203                   iscompat := false ELSE
1204                   iscompat := declproc@.proctype = foundproc@.proctype ;
1205               END ELSE
1206               iscompat := foundproc@.proctype = foundproc ;
1207           compatlist := iscompat ;
1208 $OPTIONS compile = trace $
1209           IF stattrace > low THEN
1210             BEGIN
1211               write (mpcogout, '@@@ FIN COMPATLIST @@@ WITH RETURNED VALUE ', iscompat : 6) ;
1212               nextline ;
1213             END ;
1214 $OPTIONS compile = true $
1215         END (* COMPATLIST *) ;
1216 
1217 
1218 
1219 
1220 
1221       BEGIN                                       (* PASSPARAMS *)
1222 $OPTIONS compile = trace $
1223         IF stattrace > none THEN
1224           BEGIN
1225             write (mpcogout, '@@@ DEBUT PASSPARAMS @@@ WITH FCTPLACE', fctplace) ; nextline ;
1226           END ;
1227 $OPTIONS compile = true $
1228         WITH ctptr@ DO
1229           BEGIN
1230             itisafunct := proctype # ctptr ;
1231             parmctp := formals ;                  (* FIRST DECLARED PARAMETER *)
1232             pisformal := prockind = formal ;
1233             pisext := prockind > formal ;
1234             pisimported := prockind = imported ;
1235             plevel := proclevel ;
1236             procplacew := procaddr DIV bytesinword ; (* PR4 PR6  WORD OFFSET *)
1237             nbparm := nbparproc ;                 (* NUMBER OF "ITS" IN PARAMETER LIST *)
1238             all_descriptors := pwantdescs ;
1239             procbox := ctptr ;
1240           END (* WITH CTPTR@ *) ;
1241         procnameaddr := ctptr ;
1242                                                   (* PREPARE CURRENT ARGUMENT LIST *)
1243         longlist := bytesindword (* HEADER *) + nbparm * bytesindword ;
1244         IF ctptr^.phasdescriptor OR all_descriptors THEN
1245           longlist := longlist + nbparm * bytesindword ;
1246         deplist := oldnewstor (longlist) ;        (* POINTED LATER BY ARGUMENT POINTER *)
1247         curritsw := (deplist + bytesindword) DIV bytesinword ;
1248         IF all_descriptors AND (nbparm <> 0) THEN
1249           BEGIN
1250             newbloc (pr5) ;
1251             pr5bloc := currentbloc ;
1252             usednameaddr := procnameaddr ;
1253             genstand (prlink, procplacew, iepp5, tny) ;
1254             mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1255             geneism (imlr, 0, p0t0r0) ;
1256             gendesca (prstatic, procbox^.pdescsaddrplace DIV bytesinword, 0, l9, nbparm * bytesindword, tn) ;
1257             gendesca (pr6, deplist DIV bytesinword + 2 + nbparm * 2, 0, l9, nbparm * bytesindword, tn) ;
1258           END ;
1259         IF no = 9 (* ( *) THEN
1260           BEGIN
1261             prevdecltype := NIL ; prevfoundtype := NIL ;
1262             dvdispw := 0 ; arrconfblockw := 0 ;
1263             REPEAT                                (* LOOP  ON ACTUAL  PARAMETER'S  LIST *)
1264               IF parmctp = NIL THEN
1265                 BEGIN
1266                   error (126) ; skip (46) ; GOTO 1 ; (* EXIT PROC *)
1267                 END ;
1268               paramisproc := parmctp@.klass = proc ;
1269               IF NOT paramisproc THEN
1270                 paramisvar := parmctp@.varparam ;
1271               insymbol ;
1272               IF paramisproc THEN
1273                 BEGIN                             (* PROC OR FUNCT TO BE PASSED *)
1274                   IF no # 1 THEN
1275                     BEGIN error (2) ; skip (15) ; (* , *)
1276                     END ELSE
1277                     BEGIN                         (* ID *)
1278                       search ;
1279                       IF ctptr = NIL THEN
1280                         error (104) ELSE
1281                         BEGIN
1282                           IF symbolmap THEN nameisref (ctptr, symbolfile, symbolline) ;
1283                           WITH ctptr@ DO
1284                             IF klass # proc THEN
1285                               error (103) ELSE
1286                               IF NOT compatlist (parmctp, ctptr) THEN
1287                                 error (128) ELSE
1288                                 BEGIN
1289                                   IF predefproc THEN error (28) ;
1290                                   IF prockind # formal THEN (* ACTUAL PROCEDURE PASSED *)
1291                                     BEGIN
1292                                       currparmw := oldnewstor (procparmsize) DIV bytesinword ;
1293                                       IF proclevel = level THEN
1294                                         genstand (pr6, currparmw + 2, ispri6, tn) ELSE
1295                                         BEGIN
1296                                           loadlink (pr3, proclevel) ;
1297                                           genstand (pr6, currparmw + 2, ispri3, tn) ;
1298                                         END ;
1299                                       genstand (prlink, procaddr DIV bytesinword, iepp3, tny) ;
1300                                       genstand (pr6, currparmw, ispri3, tn) ;
1301                                       IF prockind > formal THEN ldisp := extcallplace
1302                                       ELSE IF pisimported THEN error (318) ELSE ldisp := intcallplace ;
1303                                       genstand (nreg, ldisp, ilda, tdl) ;
1304                                       genstand
1305                                         (pr6, currparmw + 4, ista, tn) ; (* USED IN CALL SEQ. *)
1306                                                   (* NOW LOAD PR3 *)
1307                                                   (* WITH "ITS" ON CURRPARM *)
1308                                       usednameaddr := ctptr ;
1309                                       genstand (pr6, currparmw, iepp3, tn) ;
1310                                       genstand (pr6, curritsw, ispri3, tn) ;
1311                                     END (* NOT FORMAL *) ELSE
1312                                     BEGIN         (* FORMAL *)
1313                                       IF proclevel = level THEN
1314                                         lbase := pr6 ELSE
1315                                         BEGIN
1316                                           loadbase (proclevel) ; freebloc (currentbloc) ;
1317                                           lbase := currentpr ;
1318                                         END ;
1319                                       usednameaddr := ctptr ;
1320                                       genstand (lbase, procaddr DIV bytesinword, iepp3, tny) ;
1321                                       genstand (pr6, curritsw, ispri3, tn) ;
1322                                       IF pisimported THEN
1323                                         BEGIN
1324                                           genstand (pr3, 4, ilda, tn) ; (* CALL OP NUMBER *)
1325                                           genstand (pr0, parmproccheckplace, itsp3, tn) ;
1326                                         END ;
1327                                     END (* FORMAL *) ;
1328                                   curritsw := curritsw + 2 ;
1329                                 END (* NO ERRORS  IN PASSING A PROCEDURE/FUNCTION AS PARAMETER *) ;
1330                         END ;
1331                       insymbol ;
1332                     END (* ID *) ;
1333                 END (* PARAMISPROC *) ELSE
1334                 IF paramisvar THEN
1335                   BEGIN
1336                     variab (true) ;
1337                     done := false ;
1338                     WITH gattr DO
1339                       IF typtr # NIL THEN
1340                         IF parmctp^.vtype <> NIL THEN
1341                           BEGIN
1342                             IF (parmctp^.vtype^.father_schema <> NIL) THEN
1343                               IF (parmctp^.vtype^.actual_parameter_list = NIL) THEN (* nothing *) ELSE
1344                                 IF (parmctp^.vtype^.actual_parameter_list^.vkind = arraybound) THEN
1345                                                   (* FORMAL PARAMETER IS A SCHEMA. PASS ACTUAL BOUNDS IN DESCRIPTOR *)
1346                                   IF (typtr^.father_schema <> parmctp^.vtype^.father_schema) THEN error (127)
1347                                   ELSE
1348                                     BEGIN
1349                                       decltype := parmctp^.vtype ; foundtype := typtr ;
1350                                       lerr := false ;
1351                                       IF prevdecltype = decltype THEN
1352                                         BEGIN     (* list of parameters of same schema *)
1353                                           firstoflist := false ;
1354                                           IF prevfoundtype <> foundtype THEN
1355                                             BEGIN
1356                                               lerr := true ; error (127) ;
1357                                             END ;
1358                                         END ELSE
1359                                         BEGIN
1360                                           firstoflist := true ;
1361                                           prevfoundtype := foundtype ;
1362                                           prevdecltype := decltype ;
1363                                         END ;
1364                                       IF NOT lerr THEN
1365                                         BEGIN
1366                                           IF foundtype^.actual_parameter_list^.vkind = arraybound THEN
1367                                             BEGIN (* PASSED PARAMETER IS ITSELF A VARIABLE SCHEMA. KEEP HIS DESC *)
1368                                               IF gattr.descbloc = NIL THEN
1369                                                 BEGIN
1370                                                   init_desc_address (variabctptr, gattr) ;
1371                                                   genstand (pr6, curritsw, prinst [spri, gattr.basereg], tn) ;
1372                                                   freebloc (gattr.basebloc) ;
1373                                                 END
1374                                               ELSE
1375                                                 BEGIN
1376                                                   loadadr (gattr, pr3) ;
1377                                                   genstand (pr6, curritsw, ispri3, tn) ;
1378                                                 END ;
1379                                               IF firstoflist THEN
1380                                                 BEGIN
1381                                                   temppt := decltype^.actual_parameter_list ;
1382                                                   nbofparm := 0 ;
1383                                                   WHILE temppt <> NIL DO
1384                                                     BEGIN
1385                                                       nbofparm := nbofparm + 1 ; ; temppt := temppt^.nxtel
1386                                                     END ;
1387                                                   wlength := 2 (* MULTICS EXTENDED ARG DESC *) + 1 (* SIZE *) + nbofparm (* ONE WORD PER PARM *) ;
1388                                                   dvdispw := oldnewstor (wlength * bytesinword) DIV bytesinword ;
1389                                                   regenere (gattr.descbloc) ;
1390                                                   mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1391                                                   geneism (imlr, 0, p0t0r0) ;
1392                                                   gendesca (gattr.descreg, 2, 0, l9, (wlength - 2) * bytesinword, tn) ;
1393                                                   gendesca (pr6, dvdispw + 2, 0, l9, (wlength - 2) * bytesinword, tn) ;
1394                                                 END ;
1395                                               freebloc (gattr.descbloc) ;
1396                                               getpr ;
1397                                               genstand (pr6, dvdispw, prinst [epp, currentpr], tn) ;
1398                                               genstand (pr6, curritsw + nbparm * 2, prinst [spri, currentpr], tn) ;
1399                                               freebloc (currentbloc) ;
1400                                               curritsw := curritsw + 2 ;
1401                                             END (* Actual is Schema *) ELSE
1402                                             BEGIN
1403                                               loadadr (gattr, pr3) ;
1404                                               genstand (pr6, curritsw, ispri3, tn) ;
1405 
1406                                               IF firstoflist THEN
1407                                                 BEGIN
1408                                                   (* Evaluation du nombre de parametres *)
1409                                                   temppt := decltype^.actual_parameter_list ;
1410                                                   nbofparm := 0 ;
1411                                                   WHILE temppt <> NIL DO
1412                                                     BEGIN
1413                                                       nbofparm := nbofparm + 1 ; ; temppt := temppt^.nxtel
1414                                                     END ;
1415                                                   wlength := 2 (* MULTICS EXTENDED ARG DESC *) + 1 (* SIZE *) + nbofparm (* ONE WORD PER PARM *) ;
1416                                                   dvdispw := oldnewstor (wlength * bytesinword) DIV bytesinword ;
1417                                                   temppt := typtr^.actual_parameter_list ; tempact := foundtype ; locdisp := 2 ;
1418                                                   gencstecode (typtr^.size, ilda) ;
1419                                                   genstand (pr6, dvdispw + locdisp, ista, tn) ;
1420                                                   locdisp := locdisp + 1 ;
1421                                                   WHILE temppt <> NIL DO
1422                                                     BEGIN
1423                                                       sauvereg (ra, false) ;
1424                                                       IF temppt^.klass <> konst THEN
1425                                                         BEGIN
1426                                                           addressvar (temppt, parm_attr, false) ;
1427                                                           transfer (parm_attr, inacc) ;
1428                                                           freeattr (parm_attr)
1429                                                         END
1430                                                       ELSE gencstecode (temppt^.values, ilda) ;
1431                                                       genstand (pr6, dvdispw + locdisp, ista, tn) ;
1432 
1433                                                       locdisp := locdisp + 1 ;
1434                                                       temppt := temppt^.nxtel ;
1435                                                     END ;
1436                                                 END (* FIRSTOFLIST *) ;
1437 
1438                                               genstand (pr6, dvdispw, iepp3, tn) ;
1439                                               genstand (pr6, curritsw + nbparm * 2, ispri3, tn) ;
1440                                               curritsw := curritsw + 2 ;
1441                                             END (* Actual not Schema *) ;
1442                                         END ;
1443                                       done := true ;
1444                                     END ;
1445                             IF NOT done THEN
1446                               IF (gattr.pckd) AND (NOT parmctp^.vtype^.pack) THEN error (127) ELSE
1447                                 IF typtr = parmctp@.vtype THEN
1448                                   BEGIN
1449                                     loadadr (gattr, pr3) ;
1450                                     IF procnameaddr^.pwantspl1descriptors AND
1451                                       is_pl1_varying_char (parmctp^.vtype) THEN
1452                                       genstand (pr3, 1, iepp3, tn) ;
1453                                     genstand (pr6, curritsw, ispri3, tn) ; curritsw := curritsw + 2 ;
1454                                   END (* SAME TYPE *) ELSE
1455                                   IF NOT conformantdim (parmctp^.vtype) THEN
1456                                     error (127) ELSE
1457                                     BEGIN         (* Not Same Type *)
1458                                       decltype := parmctp^.vtype ; foundtype := gattr.typtr ;
1459                                       lerr := false ;
1460                                       IF NOT legalconfarrsubstitution (foundtype, decltype) THEN
1461                                         BEGIN
1462                                           error (127) ;
1463                                                   (* SKIP BOUNDS PARAM *)
1464                                           WHILE parmctp^.vkind = arraybound DO
1465                                             BEGIN
1466                                               parmctp := parmctp ^.nxtel ;
1467                                             END ;
1468                                         END (* not Legal Substitution *) ELSE
1469                                         BEGIN
1470                                           IF prevdecltype = decltype THEN
1471                                             BEGIN (* Liste *)
1472                                               firstoflist := false ;
1473                                               IF prevfoundtype <> foundtype THEN
1474                                                 BEGIN
1475                                                   lerr := true ; error (127) ;
1476                                                 END ;
1477                                             END ELSE
1478                                             BEGIN
1479                                               firstoflist := true ;
1480                                               prevfoundtype := foundtype ;
1481                                               prevdecltype := decltype ;
1482                                             END ;
1483                                           IF NOT lerr THEN
1484                                             BEGIN
1485                                               IF conformantdim (foundtype) THEN
1486                                                 BEGIN
1487                                                   (* Load PR3 with previous descriptor on block parameter *)
1488                                                   IF gattr.descbloc = NIL THEN
1489                                                     BEGIN
1490                                                       init_desc_address (variabctptr, gattr) ;
1491                                                       genstand (pr6, curritsw, prinst [spri, gattr.basereg], tn) ;
1492                                                       freebloc (gattr.basebloc) ;
1493                                                     END
1494                                                   ELSE
1495                                                     BEGIN
1496                                                       loadadr (gattr, pr3) ;
1497                                                       genstand (pr6, curritsw, ispri3, tn) ;
1498                                                     END ;
1499                                                   IF firstoflist THEN
1500                                                     BEGIN
1501                                                       temppt := decltype ;
1502                                                       nbofdim := 0 ;
1503                                                       WHILE conformantdim (temppt) DO
1504                                                         BEGIN
1505                                                           nbofdim := nbofdim + 1 ;
1506                                                           temppt := temppt^.aeltype ;
1507                                                           parmctp := parmctp^.nxtel^.nxtel ;
1508                                                         END ;
1509                                                       wlength := nbofdim * dopevectorsize DIV bytesinword ;
1510                                                       dvdispw := oldnewstor ((wlength + 2) * bytesinword) DIV bytesinword ;
1511                                                       IF all_descriptors THEN
1512                                                         BEGIN
1513                                                           getpr ;
1514                                                           genstand (pr6, curritsw + (nbparm * 2), prinst [epp, currentpr], tny) ;
1515                                                           mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1516                                                           geneism (imlr, 0, p0t0r0) ;
1517                                                           gendesca (currentpr, 0, 0, l9, (wlength + 2) * bytesinword, tn) ;
1518                                                           gendesca (pr6, dvdispw, 0, l9, (wlength + 2) * bytesinword, tn) ;
1519                                                           freebloc (currentbloc) ;
1520                                                         END ;
1521                                                       regenere (gattr.descbloc) ;
1522                                                       geneism (imlr, 0, p0t0r0) ;
1523                                                       gendesca (gattr.descreg, 0, 0, l9, wlength * bytesinword, tn) ;
1524                                                       gendesca (pr6, dvdispw + 1, 0, l9, wlength * bytesinword, tn) ;
1525                                                     END ;
1526                                                   freebloc (gattr.descbloc) ;
1527 
1528                                                   getpr ;
1529                                                   genstand (pr6, dvdispw, prinst [epp, currentpr], tn) ;
1530                                                   genstand (pr6, curritsw + nbparm * 2, prinst [spri, currentpr], tn) ;
1531                                                   freebloc (currentbloc) ;
1532 
1533                                                   curritsw := curritsw + 2 ;
1534 
1535                                                 END (* Actual Is Conformant *) ELSE
1536                                                 BEGIN
1537 
1538                                                   loadadr (gattr, pr3) ;
1539                                                   genstand (pr6, curritsw, ispri3, tn) ;
1540 
1541                                                   IF firstoflist THEN
1542                                                     BEGIN
1543                                                   (* Evaluation du nombre de dimensions *)
1544                                                       temppt := decltype ;
1545                                                       nbofdim := 0 ;
1546                                                       WHILE conformantdim (temppt) DO
1547                                                         BEGIN
1548                                                           nbofdim := nbofdim + 1 ;
1549                                                           temppt := temppt^.aeltype ;
1550                                                         END ;
1551 
1552 (* Acquisition dope vector *)
1553                                                       dvdispw := oldnewstor (nbofdim * dopevectorsize + 8) DIV bytesinword ;
1554                                                       wlength := nbofdim * dopevectorsize DIV bytesinword ;
1555                                                       IF all_descriptors THEN
1556                                                         BEGIN
1557                                                           getpr ;
1558                                                           genstand (pr6, curritsw + (nbparm * 2), prinst [epp, currentpr], tny) ;
1559                                                           mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1560                                                           geneism (imlr, 0, p0t0r0) ;
1561                                                           gendesca (currentpr, 0, 0, l9, (wlength + 2) * bytesinword, tn) ;
1562                                                           gendesca (pr6, dvdispw, 0, l9, (wlength + 2) * bytesinword, tn) ;
1563                                                           freebloc (currentbloc) ;
1564                                                         END ;
1565 
1566 (* Incrementation et passage des bornes *)
1567                                                       temppt := decltype ; tempact := foundtype ; locdisp := 3 * nbofdim - 2 ;
1568                                                       WHILE conformantdim (temppt) DO
1569                                                         BEGIN
1570                                                   (* PAsse Low Bound et remplit premoer mot du dope vector *)
1571                                                           lowbound := tempact^.lo ;
1572                                                           sauvereg (ra, false) ; gencstecode (lowbound, ilda) ;
1573                                                           genstand (pr6, dvdispw + locdisp, ista, tn) ;
1574 
1575 (* Passe high bound et remplit deuxieme mot du dope vector *)
1576                                                           highbound := tempact^.hi ;
1577                                                           gencstecode (highbound, ilda) ;
1578                                                           genstand (pr6, dvdispw + locdisp + 1, ista, tn) ;
1579 
1580 (* Passe MULTIPLIER *)
1581                                                           IF tempact^.pack THEN
1582                                                             multiplier := packedsize (tempact^.aeltype) * bitsinbyte ELSE
1583                                                             multiplier := sup (tempact^.aeltype^.size, bytesinword) DIV bytesinword ;
1584                                                           gencstecode (multiplier, ilda) ;
1585                                                           genstand (pr6, dvdispw + locdisp + 2, ista, tn) ;
1586 
1587 (* Prepare dimension suivante *)
1588                                                           locdisp := locdisp - 3 ;
1589                                                           temppt := temppt^.aeltype ; tempact := tempact^.aeltype ;
1590                                                           parmctp := parmctp^.nxtel^.nxtel ;
1591 
1592                                                         END ;
1593                                                     END (* FIRSTOFLIST *) ;
1594 
1595                                                   genstand (pr6, dvdispw, iepp3, tn) ; (* Dope vector address *)
1596                                                   genstand (pr6, curritsw + nbparm * 2, ispri3, tn) ;
1597                                                   curritsw := curritsw + 2 ;
1598                                                 END (* Actual not conformant *) ;
1599                                             END (* not LERR *) ;
1600                                         END (* Legal Substitution *) ;
1601                                     END (* Not Same Type *) ;
1602                           END (* TYPTR#NIL,WITH GATTR *) ;
1603                   END (* PARAMISVAR *) ELSE
1604                   BEGIN                           (* VALUE PARAMETER *)
1605                     expression ;
1606                     WITH gattr DO
1607                       IF typtr <> NIL THEN
1608                         BEGIN
1609                           compatbin (parmctp^.vtype, typtr, generic) ;
1610                           IF generic = NIL THEN
1611                             BEGIN
1612                               IF parmctp^.vtype = NIL THEN (* nothing *)
1613                               ELSE IF parmctp^.vtype^.father_schema = string_ptr
1614                                 THEN IF (parmctp^.vtype^.actual_parameter_list = NIL) THEN (* nothing *)
1615                                   ELSE
1616                                     BEGIN
1617                                       IF parmctp^.vtype^.actual_parameter_list^.klass = konst THEN
1618                                         formal_length := parmctp^.vtype^.actual_parameter_list^.values
1619                                       ELSE formal_length := 0 ; (* ERROR SOMEWHERE BEFORE *)
1620                                       currparmw := oldnewstor (formal_length + 4) DIV bytesinword ;
1621                                       IF typtr^.father_schema = string_ptr THEN
1622                                         BEGIN
1623                                           loadadr (gattr, pr3) ;
1624                                           genstand (pr3, 0, ildq, tn) ;
1625                                           genstand (nreg, 4, iadq, tdl) ;
1626                                           gencstecode (formal_length + 4, ilda) ;
1627                                           mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
1628                                           geneism (imlr, 0, p0t0r0) ;
1629                                           gendesca (pr3, 0, 0, l9, 0, tql) ;
1630                                           gendesca (pr6, currparmw, 0, l9, 0, tal) ;
1631                                           IF procnameaddr^.pwantspl1descriptors THEN
1632                                             genstand (pr6, currparmw + 1, iepp3, tn)
1633                                           ELSE
1634                                             genstand (pr6, currparmw, iepp3, tn) ;
1635                                           genstand (pr6, curritsw, ispri3, tn) ;
1636                                         END ELSE
1637                                         IF typtr = charptr THEN
1638                                           BEGIN
1639                                             IF kind = lval THEN loaded_reg := ldreg
1640                                             ELSE
1641                                               IF raisused THEN
1642                                                 BEGIN
1643                                                   loaded_reg := rq ; sauvereg (rq, false) ;
1644                                                   transfer (gattr, inq) ;
1645                                                 END ELSE
1646                                                 BEGIN
1647                                                   loaded_reg := ra ;
1648                                                   transfer (gattr, inacc) ;
1649                                                 END ;
1650                                             freeattr (gattr) ;
1651                                             genstand (nreg, 27, opaq [shiftl, loaded_reg], tn) ;
1652                                             genstand (pr6, currparmw + 1, opaq [stor, loaded_reg], tn) ;
1653                                             genstand (nreg, 1, opaq [load, loaded_reg], tdl) ;
1654                                             genstand (pr6, currparmw, opaq [stor, loaded_reg], tn) ;
1655                                             IF procnameaddr^.pwantspl1descriptors THEN
1656                                               genstand (pr6, currparmw + 1, iepp3, tn)
1657                                             ELSE
1658                                               genstand (pr6, currparmw, iepp3, tn) ;
1659                                             genstand (pr6, curritsw, ispri3, tn) ;
1660                                           END
1661                                         ELSE IF isstring (gattr) THEN
1662                                             BEGIN
1663                                               IF NOT conformantdim (typtr) THEN
1664                                                 BEGIN
1665                                                   loadadr (gattr, pr3) ;
1666                                                   sauvereg (ra, false) ;
1667                                                   IF kind = chain THEN
1668                                                     BEGIN
1669                                                       IF alfactp^.alfalong > formal_length THEN error (127) ;
1670                                                       gencstecode (alfactp^.alfalong, ilda) ;
1671                                                     END
1672                                                   ELSE BEGIN
1673                                                       IF typtr^.size > formal_length THEN error (127) ;
1674                                                       gencstecode (typtr^.size, ilda) ;
1675                                                     END ;
1676                                                   mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
1677                                                   genstand (pr6, currparmw, ista, tn) ;
1678                                                   geneism (imlr, 0, p0t0r0) ;
1679                                                   gendesca (pr3, 0, 0, l9, 0, tal) ;
1680                                                   gendesca (pr6, currparmw + 1, 0, l9, 0, tal) ;
1681                                                   IF procnameaddr^.pwantspl1descriptors THEN
1682                                                     genstand (pr6, currparmw + 1, iepp3, tn)
1683                                                   ELSE
1684                                                     genstand (pr6, currparmw, iepp3, tn) ;
1685                                                   genstand (pr6, curritsw, ispri3, tn) ;
1686                                                 END
1687                                               ELSE (* conformant string *)
1688                                                 BEGIN
1689                                                   init_desc_address (gattr.nameaddr, gattr) ;
1690                                                   sauvereg (rq, false) ;
1691                                                   genstand (gattr.descreg, 1, ildq, tn) ;
1692                                                   genstand (gattr.descreg, 0, isbq, tn) ;
1693                                                   genstand (nreg, 1, iadq, tdl) ; (* rq contains actual length *)
1694                                                   freebloc (gattr.descbloc) ;
1695                                                   genstand (pr6, currparmw, istq, tn) ;
1696                                                   mfari1 := a1r1i0 ; mfari2 := a1r1i0 ;
1697                                                   gencstecode (formal_length, ilda) ;
1698                                                   genstand (pr6, currparmw, iepp3, tn) ;
1699                                                   IF gattr.basebloc <> NIL THEN regenere (gattr.basebloc) ;
1700                                                   geneism (imlr, 0, p0t0r0) ;
1701                                                   gendesca (gattr.basereg, gattr.dplmt DIV bytesinword, gattr.dplmt MOD bytesinword, l9, 0, tql) ;
1702                                                   gendesca (pr3, 1, 0, l9, 0, tal) ;
1703                                                   freebloc (gattr.basebloc) ;
1704                                                   IF procnameaddr^.pwantspl1descriptors THEN
1705                                                     genstand (pr3, 1, iepp3, tn) ;
1706                                                   genstand (pr6, curritsw, ispri3, tn) ;
1707                                                 END
1708                                             END ELSE error (127) ;
1709                                       curritsw := curritsw + 2 ;
1710                                     END ELSE
1711                                   BEGIN
1712                                     IF conformantdim (parmctp^.vtype) THEN
1713                                       BEGIN       (* CONFORMARRAY VALUE SUBSTITUTION *)
1714                                         decltype := parmctp^.vtype ; foundtype := gattr.typtr ;
1715                                         lerr := false ;
1716                                         IF NOT legalconfarrsubstitution (foundtype, decltype) THEN
1717                                           BEGIN
1718                                             error (127) ;
1719                                           END (* not LEGAL SUBSTITUTION *) ELSE
1720                                           BEGIN
1721                                             IF prevdecltype = decltype THEN
1722                                               BEGIN (* LISTE *)
1723                                                 firstoflist := false ;
1724                                                 IF prevfoundtype <> foundtype THEN
1725                                                   BEGIN
1726                                                     lerr := true ; error (127) ;
1727                                                   END ;
1728                                               END ELSE
1729                                               BEGIN
1730                                                 firstoflist := true ;
1731                                                 prevfoundtype := foundtype ;
1732                                                 prevdecltype := decltype ;
1733                                               END ;
1734                                             IF NOT lerr THEN
1735                                               BEGIN
1736                                                   (* RECOPIE TABLEAU ACTUEL  *)
1737                                                 IF gattr.typtr = alfaptr THEN
1738                                                   BEGIN
1739                                                     foundsize := alfactp^.alfalong ;
1740                                                     alfalow := 1 ; alfahigh := foundsize ;
1741                                                   END ELSE
1742                                                   BEGIN
1743                                                     foundsize := gattr.typtr^.size ;
1744                                                     alfalow := 0 ; alfahigh := 0 ;
1745                                                   END ;
1746 
1747                                                 currparb := oldnewstor (recadre (foundsize, bytesinword)) ;
1748                                                 currparmw := currparb DIV bytesinword ;
1749                                                 WITH lattr DO
1750                                                   BEGIN
1751                                                     typtr := parmctp^.vtype ;
1752                                                     initattrvarbl (lattr) ;
1753                                                     dplmt := currparb ; pckd := parmctp^.vtype^.pack ;
1754                                                   END ;
1755                                                 lbase := nreg ;
1756                                                 lpad := ord (' ') ;
1757                                                 IF gattr.kind = varbl THEN
1758                                                   IF varissimple (gattr) THEN
1759                                                     BEGIN
1760                                                       lbase := basereg ; ldisp := dplmt DIV bytesinword ;
1761                                                       lmod := dplmt MOD bytesinword ;
1762                                                     END ;
1763                                                 IF lbase = nreg THEN
1764                                                   BEGIN
1765                                                     loadadr (gattr, pr3) ;
1766                                                     lbase := pr3 ; ldisp := 0 ; lmod := 0 ;
1767                                                   END ;
1768 
1769                                                 IF foundsize < twoto12 THEN
1770                                                   BEGIN
1771                                                     mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; lftag := tn ; rgtag := tn ;
1772                                                   END ELSE
1773                                                   BEGIN
1774                                                     mfari1 := a1r1i0 ; mfari2 := a1r1i0 ; lftag := tx6 ;
1775                                                     rgtag := tx7 ;
1776                                                     IF foundsize > twoto17m1 THEN
1777                                                       error (307) ELSE
1778                                                       BEGIN
1779                                                         genstand (nreg, foundsize, ieax6, tn) ;
1780                                                         genstand (nreg, foundsize, ieax7, tn) ;
1781                                                       END ;
1782                                                     foundsize := 0 ;
1783                                                   END ;
1784                                                 geneism (imlr, lpad, p0t0r0) ;
1785                                                 IF kind = varbl THEN usednameaddr := nameaddr ;
1786                                                 gendesca (lbase, ldisp, lmod, l9, foundsize, rgtag) ;
1787                                                 gendesca (pr6, currparmw, 0, l9, foundsize, lftag) ;
1788                                                 genstand (pr6, currparmw, iepp3, tn) ;
1789                                                 genstand (pr6, curritsw, ispri3, tn) ;
1790 
1791                                                 IF firstoflist THEN
1792                                                   BEGIN
1793                                                   (* EVALUATION DU NOMBRE DE DIMENSIONS *)
1794                                                     temppt := decltype ;
1795                                                     nbofdim := 0 ;
1796                                                     WHILE conformantdim (temppt) DO
1797                                                       BEGIN
1798                                                         nbofdim := nbofdim + 1 ;
1799                                                         temppt := temppt^.aeltype ;
1800                                                       END ;
1801                                                   (* ACQUISITION DOPE VECTOR *)
1802                                                     dvdispw := oldnewstor (nbofdim * dopevectorsize + 8) DIV
1803                                                     bytesinword ;
1804                                                     wlength := nbofdim * dopevectorsize DIV bytesinword ;
1805                                                     IF all_descriptors THEN
1806                                                       BEGIN
1807                                                         getpr ;
1808                                                         genstand (pr6, curritsw + (nbparm * 2), prinst [epp, currentpr], tny) ;
1809                                                         mfari1 := a1r0i0 ; mfari2 := a1r0i0 ;
1810                                                         geneism (imlr, 0, p0t0r0) ;
1811                                                         gendesca (currentpr, 0, 0, l9, (wlength + 2) * bytesinword, tn) ;
1812                                                         gendesca (pr6, dvdispw, 0, l9, (wlength + 2) * bytesinword, tn) ;
1813                                                         freebloc (currentbloc) ;
1814                                                       END ;
1815 
1816 (* INCREMENTATION ET PASSAGE DES BORNES *)
1817                                                     temppt := decltype ; tempact := foundtype ; locdisp := 3 * nbofdim - 2 ;
1818                                                     WHILE conformantdim (temppt) DO
1819                                                       BEGIN
1820                                                   (* PASSE LOW BOUND ET REMPLIT PREMOER MOT DU DOPE VECTOR *)
1821                                                         IF alfalow <> 0 THEN
1822                                                           lowbound := alfalow ELSE
1823                                                           lowbound := tempact^.lo ;
1824                                                         sauvereg (ra, false) ; gencstecode (lowbound, ilda) ;
1825                                                         genstand (pr6, dvdispw + locdisp, ista, tn) ;
1826 
1827 (* PASSE HIGH BOUND ET REMPLIT DEUXIEME MOT DU DOPE VECTOR *)
1828                                                         IF alfahigh <> 0 THEN
1829                                                           highbound := alfahigh ELSE
1830                                                           highbound := tempact^.hi ;
1831                                                         gencstecode (highbound, ilda) ;
1832                                                         genstand (pr6, dvdispw + locdisp + 1, ista, tn) ;
1833 
1834 (* PASSE MULTIPLIER *)
1835                                                         IF tempact^.pack THEN
1836                                                           multiplier := packedsize (tempact^.aeltype) * bitsinbyte ELSE
1837                                                           multiplier := sup (tempact^.aeltype^.size, bytesinword) DIV bytesinword ;
1838                                                         gencstecode (multiplier, ilda) ;
1839                                                         genstand (pr6, dvdispw + locdisp + 2, ista, tn) ;
1840 
1841 (* PREPARE DIMENSION SUIVANTE *)
1842                                                         locdisp := locdisp - 3 ;
1843                                                         temppt := temppt^.aeltype ; tempact := tempact^.aeltype ;
1844                                                         parmctp := parmctp^.nxtel^.nxtel ;
1845 
1846                                                       END ;
1847                                                   END (* FIRSTOFLIST *) ;
1848 
1849                                                 genstand (pr6, dvdispw, iepp3, tn) ;
1850                                                 genstand (pr6, curritsw + nbparm * 2, ispri3, tn) ;
1851                                                 curritsw := curritsw + 2 ;
1852                                               END (* not LERR *) ;
1853                                           END (* LEGAL SUBSTITUTION *) ;
1854                                       END (* CONFORMANT ARRAY VALUE SUBSTITUTION *) ELSE
1855                                       error (127) ;
1856                                   END ;
1857                             END (* GENERIC WAS nil *) ELSE
1858 
1859                             BEGIN declsize := parmctp@.vtype@.size ;
1860                               CASE parmctp@.vtype@.form OF
1861                                 reel : IF typtr # realptr THEN convreal (gattr) ;
1862                                 numeric, scalar :
1863                                   IF typtr = realptr THEN error (127) ELSE
1864                                     IF kind = sval THEN
1865                                       checkminmax (val, parmctp@.vtype, 303) ELSE
1866                                       IF asscheck THEN
1867                                         BEGIN
1868                                           IF kind # lval THEN transfer (gattr, inacc) ;
1869                                           checkbnds (parerrcode, ldreg, parmctp@.vtype) ;
1870                                         END ;
1871                                 pointer, records, power : foundsize := typtr@.size ;
1872                                 arrays : BEGIN
1873                                     lerr := false ;
1874                                     IF typtr = alfaptr THEN
1875                                       BEGIN foundsize := alfactp@.alfalong ;
1876                                         IF envstandard <> stdextend THEN
1877                                           BEGIN
1878                                             IF foundsize # declsize THEN lerr := true ;
1879                                           END ELSE
1880                                           IF foundsize > declsize THEN lerr := true ;
1881                                       END (* ALFAPTR *) ELSE
1882                                       BEGIN
1883                                         foundsize := typtr@.size ;
1884                                         IF foundsize # declsize THEN lerr := true ;
1885                                       END ;
1886                                     IF lerr THEN error (127) ;
1887                                   END (* ARRAYS *) ;
1888                               END (* CASE *) ;
1889                               currparb := oldnewstor (recadre (declsize, bytesinword)) ;
1890                               currparmw := currparb DIV bytesinword ;
1891                               WITH lattr DO
1892                                 BEGIN
1893                                   typtr := parmctp@.vtype ;
1894                                   initattrvarbl (lattr) ;
1895                                   dplmt := currparb ;
1896                                   pckd := parmctp@.vtype@.pack ;
1897                                 END ;
1898                               IF typtr@.form < power THEN
1899                                 BEGIN
1900                                   choicerarq ;
1901                                   transfer (lattr, out) ;
1902                                 END (* < POWER *) ELSE
1903                                 BEGIN
1904                                   IF kind = lval THEN (* ONLY POWER *)
1905                                     transfer (lattr, out) ELSE
1906                                     BEGIN
1907                                       IF typtr@.form = power THEN
1908                                         BEGIN lpad := 0 ;
1909                                           IF kind = sval THEN
1910                                             BEGIN
1911                                               IF longv = bytesindword THEN
1912                                                 BEGIN enterlcst (valpw, lretpt) ;
1913                                                   enterundlab (lretpt@.lplace) ;
1914                                                   foundsize := bytesindword ;
1915                                                 END ELSE
1916                                                 BEGIN enterllcst (valpw, llretpt) ;
1917                                                   enterundlab (llretpt@.llplace) ;
1918                                                 END ;
1919                                               genstand (nreg, 0, iepp3, tic) ;
1920                                               lbase := pr3 ;
1921                                               ldisp := 0 ;
1922                                               lmod := 0 ;
1923                                             END (* SVAL *) ELSE
1924                                             lbase := nreg ;
1925                                         END (* POWER *) ELSE
1926                                         BEGIN lpad := ord (' ') ; lbase := nreg ;
1927                                         END ;
1928                                       IF kind = varbl THEN
1929                                         IF varissimple (gattr) THEN
1930                                           BEGIN
1931                                             lbase := basereg ;
1932                                             ldisp := dplmt DIV bytesinword ;
1933                                             lmod := dplmt MOD bytesinword ;
1934                                           END ;
1935                                       IF lbase = nreg THEN
1936                                         BEGIN
1937                                           loadadr (gattr, pr3) ;
1938                                           lbase := pr3 ;
1939                                           ldisp := 0 ;
1940                                           lmod := 0 ;
1941                                         END ;
1942                                       suplr := sup (foundsize, declsize) ;
1943                                       IF suplr < twoto12 THEN
1944                                         BEGIN
1945                                           mfari1 := a1r0i0 ; mfari2 := a1r0i0 ; lftag := tn ; rgtag := tn ;
1946                                         END ELSE
1947                                         BEGIN
1948                                           mfari1 := a1r1i0 ; mfari2 := a1r1i0 ; lftag := tx6 ; rgtag := tx7 ;
1949                                           IF suplr > twoto17m1 THEN
1950                                             error (307) ELSE
1951                                             BEGIN
1952                                               genstand (nreg, declsize, ieax6, tn) ;
1953                                               genstand (nreg, foundsize, ieax7, tn) ;
1954                                             END ;
1955                                           declsize := 0 ; foundsize := 0 ;
1956                                         END ;
1957                                       geneism (imlr, lpad, p0t0r0) ;
1958                                       IF kind = varbl THEN usednameaddr := nameaddr ;
1959                                       gendesca (lbase, ldisp, lmod, l9, foundsize, rgtag) ;
1960                                       gendesca (pr6, currparmw, 0, l9, declsize, lftag) ;
1961                                       BEGIN
1962                                       END ;
1963                                     END (* >=POWER *) ;
1964                                 END ;
1965                               IF procnameaddr^.pwantspl1descriptors AND
1966                                 is_pl1_varying_char (parmctp^.vtype) THEN
1967                                 genstand (pr6, currparmw + 1, iepp3, tn)
1968                               ELSE
1969                                 genstand (pr6, currparmw, iepp3, tn) ;
1970                               genstand (pr6, curritsw, ispri3, tn) ;
1971                               curritsw := curritsw + 2 ;
1972                             END (* GENERIC NOT NIL *) ;
1973                         END (* TYPTR # NIL,WITH GATTR *) ;
1974                   END (* VALUE PARAMETER *) ;
1975               parmctp := parmctp@.nxtel ;
1976 2 :           IF parmctp <> NIL THEN              (* FOR SECURITY, IN CASE OF ERROR, SKIP CONF. ARRAY DIMS *)
1977                 IF parmctp^.vkind = arraybound THEN
1978                   BEGIN
1979                     parmctp := parmctp^.nxtel ;
1980                     GOTO 2
1981                   END ;
1982               IF no <> 15 THEN                    (* NOT , *)
1983                 BEGIN
1984                   IF no <> 10 (*    )    *) THEN
1985                     IF parmctp <> NIL THEN
1986                       BEGIN error (15) ; skip (15) ;
1987                       END ;
1988                 END ;
1989             UNTIL no # 15 ;                       (* , *)
1990             IF no = 10 THEN
1991               insymbol ELSE
1992               BEGIN
1993                 error (4) ; skip (46) ;
1994               END ;
1995           END (* NO=9 *) ;
1996         IF parmctp # NIL THEN
1997           error (126) ;
1998         IF itisafunct THEN
1999           BEGIN
2000             genstand (pr6, fctplace DIV bytesinword, iepp3, tn) ;
2001             genstand (pr6, curritsw, ispri3, tn) ;
2002           END ;
2003         IF pisformal THEN
2004           BEGIN
2005             ltag := tx7 ; ldisp := 0 ;
2006             IF plevel = level THEN
2007               lbase := pr6 ELSE
2008               BEGIN
2009                 loadbase (plevel) ; lbase := currentpr ; freebloc (currentbloc) ;
2010               END ;
2011             usednameaddr := procnameaddr ;
2012             genstand (lbase, procplacew, iepp5, tny) ; (* ITS ON PROC INFO *)
2013             genstand (pr5, 2, iepp1, tny) ;       (* PR1 = D-LINK *)
2014                                                   (* NOW  LOAD X7  WITH *)
2015                                                   (* CODE  INTERNAL-EXTERNAL  CALL *)
2016             genstand (pr5, 4, ilxl7, tn) ;        (* OPERATOR NUMBER *)
2017             genstand (pr5, 0, iepp5, tny) ;       (*  PROCEDURE ENTRY POINT *)
2018           END (* FORMAL *) ELSE
2019           BEGIN
2020             ltag := tn ;
2021             IF pisext THEN
2022               ldisp := extcallplace ELSE
2023               ldisp := intcallplace ;
2024             loadlink (pr1, plevel) ;
2025             IF all_descriptors AND (nbparm <> 0) THEN
2026               BEGIN
2027                 regenere (pr5bloc) ;
2028                 freebloc (pr5bloc) END ELSE
2029               BEGIN
2030                 usednameaddr := procnameaddr ;
2031                 genstand (prlink, procplacew, iepp5, tny) ;
2032               END ;
2033           END ;
2034                                                   (* LOAD  X1  WITH *)
2035                                                   (* PARAMETER LIST DISPLACEMENT *)
2036         genstand (pr6, deplist DIV bytesinword, ieax1, tn) ;
2037                                                   (* 2* NBPARPROC IN A 0..17 *)
2038         genstand (nreg, 2048 * nbparm, ifld, tdl) ;
2039         IF all_descriptors THEN
2040           genstand (nreg, nbparm * 2, ildq, tdu) ;
2041         genstand (pr0, ldisp, itsp3, ltag) ;
2042         IF pisext OR ((envstandard <> stdpure) AND pisformal) THEN
2043           genstand (pr6, pr4depw, iepp4, tny) ;
2044 1 :
2045 $OPTIONS compile = trace $
2046         IF stattrace > low THEN
2047           BEGIN
2048             write (mpcogout, '@@@ FIN PASSPARAMS @@@  WITH NO', no : 4) ; nextline ;
2049           END ;
2050 $OPTIONS compile = true $
2051       END (* PASSPARAMS *) ;
2052 
2053     BEGIN
2054     END.