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 (* ******************************************************************************************
  19    *                                                                                          *
  20    *                            MULTICS  PASCAL  COMPILER                                     *
  21    *                            _________________________                                     *
  22    *                                                                                          *
  23    *  This compiler is the result of a team work .                                            *
  24    *  Three people  Jean.Michel Athane   ( C.I.C.G   ),  Jean.Pierre Fauche (CRISS-IREP)      *
  25    *                Bernard Huc    (C.S.L./C.T.G. )                                           *
  26    *     during one year,(some nights and week-ends ...) worked together  for this            *
  27    *     result. If you are not happy with this compiler,you can (must) see one of these      *
  28    *     three people. For this reason, their addresses are not given here.                   *
  29    *  We hope anyway ,you don't have any trouble with this fine,sophisticated compiler.       *
  30    *                                                                                          *
  31    *  Some of data structures used in some places are derived from the original CDC compiler  *
  32    *     issued in Zurich in 1972 by N. Wirth and his team.                                   *
  33    *  The experience of CRISS on Pascal compilers is also included here, as well as the ideas *
  34    *     taken (judiciously chosen) in the SFER Pascal compiler.                              *
  35    *  It is obvious that the authors have developped here their personal ideas.            *
  36    *  Sorry for this....                                                                   *
  37    *                                                                                          *
  38    *          at GRENOBLE (FRANCE)  on August,28th  1980.                                     *
  39    *            sincerely yours,                                                              *
  40    *                           the authors                                                    *
  41    *                                                                                          *
  42    ****************************************************************************************** *)
  43 $OPTIONS page $
  44 
  45 $OPTIONS switch trace := true ; switch security := true ; t - $
  46   PROGRAM racine (mpcogerr, mpcogin, mpcogout) ;
  47     $IMPORT
  48                                                   (* LIST  OF IMPORTED  PROCEDURES *)
  49       'UNIQUE (pascal)' :
  50         displaysymbols,
  51         heaperror,
  52         initclasse,
  53         initialise,
  54         progdecl,
  55         prterrmeans,
  56         statistiques ;
  57       'DECLARE (pascal)' :
  58         body ;
  59       'CONTEXTTABLE (pascal)' :
  60         create_dummyclass_box,
  61         create_vars_box ;
  62       'STATE (pascal)' :
  63         freeallregisters ;
  64       'EXPR (pascal)' :
  65         expression ;
  66       'MODATTR (pascal)' :
  67         initattrvarbl ;
  68       'GENERE (pascal)' :
  69         genlongprofileref,
  70         genprofileref,
  71         inser ;
  72       'optimized_procedures (alm)' :
  73         search,
  74         srchrec ;
  75       'pascal (pl1)' :
  76         listhead ;
  77                                                   (* LIST OF IMPORTED VARIABLES    *)
  78       'STATE (pascal)' :
  79         asscheck,
  80         divcheck,
  81         errorctp,
  82         gattr,
  83         inputctp,
  84         inxcheck,
  85         outputctp,
  86         stattrace ;
  87       'DECLARE (pascal)' :
  88         building_from_schema,
  89         decltrace,
  90         externallistheader,
  91         filpts,
  92         filtop,
  93         forbidden_id_list,
  94         hdrfile,
  95         hdrindex,
  96         hdrlength,
  97         hdrline,
  98         lc,
  99         lkc,
 100         symbtabl ;
 101       'GENERE (pascal)' :
 102         fichinter,
 103         genetrace,
 104         ic,
 105         illegal_generation,
 106         outcode,
 107         writecode ;
 108                                                   (* FROM PL/1 *)
 109       'pascal_build_object$pascal_build_object (pl1)' : buildobject ;
 110       'pascal_sources_management_$init_source (pl1)' : initsource ;
 111       'pascal_sources_management_$begin_source (pl1)' : beginsource ;
 112       'pascal_sources_management_$end_source (pl1)' : endsource ;
 113       'pascal_sources_management_$display_sources (pl1)' : displaysources ;
 114       'pascal_statement_map_$return_map_ptr (pl1)' : getmapptr ;
 115       'pascal_statement_map_$return_prof_ptr (pl1)' : getprofptr ;
 116       'pascal_convert_real$pascal_convert_real (pl1)' : convertreal ;
 117       'pascal_gen_io_ref_ (pl1)' : geninput, genoutput, genentree, gensortie, generror, generreur
 118       $
 119 
 120     $EXPORT
 121 
 122       alfaptr,
 123       anytrace,
 124       aval,
 125       boolptr,
 126       boxheader,
 127       bufval,
 128       ch8flag,
 129       charptr,
 130       chnix,
 131       cl,
 132       codelist,
 133       conint,
 134       conreel,
 135       crealfabox,
 136       ctptr,
 137       currentnode,
 138       declarationpart,
 139       display,
 140       disx,
 141       environt,
 142       envstandard,
 143       errcl,
 144       error,
 145       errorflag,
 146       errorsfound,
 147       errtotal,
 148       exportablecode,
 149       extcalltrapplace,
 150       check_id,
 151       fastoperator,
 152       firstcond,
 153       forbidden_id,
 154       init_fsb_trap_flag,
 155       init_fsb_trap_info_place,
 156       init_fsb_trap_links_place,
 157       init_fsb_trap_number_of_files,
 158       generrorlink,
 159       geninputlink,
 160       genoutputlink,
 161       inconst,
 162       initracine,
 163       inputflag,
 164       inserundlab,
 165       insymbol,
 166       interactive,
 167       intptr,
 168       iowarnings,
 169       ival,
 170       lamptr,
 171       lastproc,
 172       level,
 173       liglues,
 174       linkswordcount,
 175       listyes,
 176       longchaine,
 177       longprofile,
 178       longstring,
 179       majmin,
 180       mapswitch,
 181       maxstring_ptr,
 182       mpcogerr,
 183       mpcogin,
 184       mpcogout,
 185       nameisref,
 186       next,
 187       nextline,
 188       nextpage,
 189       nilptr,
 190       no,
 191       no_compilation_warnings,
 192       outputflag,
 193       pageserrors,
 194       pascalfrench,
 195       pnumptr,
 196       poweroftwo,
 197       profilewordcount,
 198       profptr,
 199       progname,
 200       programnode,
 201       realptr,
 202       recadre,
 203       returnstop,
 204       rval,
 205       selectivetable,
 206       skip,
 207       skipextd,
 208       skiptochapter,
 209       sourceindex,
 210       sourcenbr,
 211       startic,
 212       statement_begins,
 213       statement_ends,
 214       staticswordcount,
 215       statnbr,
 216       string_ptr,
 217       sttfile,
 218       sttindex,
 219       sttline,
 220       sup,
 221       symbolfile,
 222       symbolindex,
 223       symbolline,
 224       symbolmap,
 225       textfilectp,
 226       top,
 227       undecptr,
 228       undlab,
 229       usednames,
 230       version,
 231       warning,
 232       xc,
 233       xrefneed $
 234 
 235 
 236 
 237     LABEL 100 ;                                   (* END OF THE COMPILATION *)
 238 
 239 
 240 
 241 
 242 
 243 $OPTIONS page $
 244 
 245 $INCLUDE 'CONSTTYPE' $
 246 
 247 
 248 
 249 $OPTIONS page $
 250 
 251     VAR
 252                                                   (* REDEFINE IMPORTED VARIABLES  *)
 253                                                   (* FROM STATE *)
 254       asscheck : boolean ;
 255       divcheck : boolean ;
 256       errorctp : ctp ;
 257       gattr : attr ;
 258       inputctp : ctp ;
 259       inxcheck : boolean ;
 260       outputctp : ctp ;
 261       stattrace : levtrace ;
 262                                                   (* FROM DECLARE *)
 263       building_from_schema : schema_status ;
 264       decltrace : levtrace ;
 265       externallistheader : ptexternalitem ;
 266       forbidden_id_list : alfalistptr ;
 267       hdrfile : integer ;
 268       hdrindex : integer ;
 269       hdrlength : integer ;
 270       hdrline : integer ;
 271       filpts : ARRAY [0..fillimit] OF ctp ;
 272       filtop : integer ;
 273       lc : integer ;
 274       lkc : integer ;
 275       symbtabl : boolean ;
 276                                                   (* FROM GENERE  *)
 277       fichinter : ^binartype ;
 278       genetrace : levtrace ;
 279       ic : integer ;
 280       illegal_generation : boolean ;
 281       outcode : boolean ;
 282       writecode : boolean ;
 283 
 284 (* DEFINE  EXPORTABLE  VARIABLES *)
 285       alfaptr : ctp ;                             (* CHAR'S STRINGS TYPE POINTER *)
 286       anytrace : levtrace ;
 287       aval : alfaid ;                             (* OUTPUT OF  INSYM BOL *)
 288       boolptr : ctp ;                             (* BOOLEAN TYPE POINTER *)
 289       boxheader : PACKED ARRAY [1..120] OF char ; (* USED TO PRINT *)
 290                                                   (* BOXES IN TRACE ENVIRONEMENT   *)
 291       bufval : ARRAY [1..maxval] OF char ;        (* OUTPUT OF INSYMBOL *)
 292       ch8flag : boolean ;
 293       check_id : boolean ;
 294       charptr : ctp ;                             (* CHAR TYPE POINTER *)
 295       chnix : integer ;                           (* POINTS THE HEAD OF *)
 296                                                   (* FREE LIST IN UNDLAB *)
 297       cl : integer ;                              (* OUTPUT OF INSYMBOL *)
 298       codelist : boolean ;                        (* TRUE IF "-list" OPTION *)
 299       conint : integer ;                          (* OUTPUT OF INSYMBOL *)
 300       conreel : real ;                            (*   "      "    "   *)
 301       ctptr : ctp ;                               (* OUTPUT  OF   SRCHREC  AND  SEARCH  *)
 302       currentnode : blocknodeptr ;                (* PTR TO CURRENT PROC NODE *)
 303       declarationpart : boolean ;
 304       display : ARRAY [0..displimit] OF recidscope ;
 305 
 306 (*  EACH ENTRY (0..TOP)   IS   THE  BEGINNING  OF A LIST  OF
 307    IDENTIFIERS  IN CONTEXTTABLE.
 308    EACH LIST  CORRESPONDS
 309    EITHER   AT   A LEVEL   ( PROC  NESTED)
 310    EITHER   AT   A SCOPE DUE TO A WITH
 311    THE  ORDER  OF SCANNING  GIVES   THE  PASCAL  SCOPE  *)
 312       disx : integer ;                            (* FIRST FREE ENTRY IN DISPLAY *)
 313                                                   (* TO  DECIDE   BETWEEN   DIGIT.. *)
 314                                                   (* OR  DIGIT.DIGIT  IN INSYMBOL *)
 315       environt : contexte ;
 316                                                   (*  DATA, CODE  , AND SO ON..  *)
 317       envstandard : stdkind ;
 318       errcl : ARRAY [norange] OF typofsymb ;
 319                                                   (* ERROR RECOVERY IN  PASCAL PROGRAM *)
 320                                                   (* (NOT IN TYPE PART)  *)
 321       errorflag : ptexternalitem ;
 322       errorsfound : ARRAY [0..maxerpg] OF SET OF 0..maxset ;
 323                                                   (* SUMMARY OF ENCOUNTERED  ERRORS *)
 324                                                   (* DURING THETOTAL  COMPILATION *)
 325       errtotal : integer ;
 326                                                   (*  GIVES TOTAL NUMBER OF *)
 327                                                   (* ENCOUNTERED ERRORS *)
 328       exportablecode : boolean ;
 329       extcalltrapplace : integer ;                (* IF NON NULL BYTE DISP IN LINK OF LINK TO EXT CALL TRAP PROC *)
 330       fastoperator : boolean ;                    (* INIT IN CARTEEXEC. *)
 331                                                   (* FORCES FAST OPERATORS TO BE CALLED *)
 332                                                   (* USED IN GENERE    *)
 333       firstcond : condaddr ;                      (* PRT TO FIRST CONDITIONNAL VARIABLE BOX *)
 334       forbidden_id : alfaid ;                     (* IDENTIFIER FORBIDDEN IF CHECK_ID IS TRUE *)
 335       init_fsb_trap_flag : boolean ;              (* TRUE IF FSB INITIALIZED BY F.REF. TRAP *)
 336       init_fsb_trap_info_place,                   (* BYTE DISP IN TEXT OF OINFO FOR THIS TRAP *)
 337       init_fsb_trap_links_place,                  (* BYTE DISP IN LINK OF LINKS FOR THIS TRAP *)
 338       init_fsb_trap_number_of_files : integer ;   (* NBR OF FILES INIT. BY THIS TRAP *)
 339       inputflag : ptexternalitem ;                (* #0 IF INPUT IS IN PRG. PARAM. *)
 340       interactive : boolean ;                     (* TRUE IF INTERACTIVE MODE *)
 341       intptr : ctp ;                              (* INTEGER TYPE POINTER *)
 342       iowarnings : boolean ;                      (* TRUE IF IO WARNINGS WANTED (DEFAULT) *)
 343       ival : integer ;                            (* OUTPUT OF  INSYMBOL *)
 344       lamptr : ctp ;                              (*  POINTS   EMPTY SET TYPE *)
 345       lastproc : blocknodeptr ;                   (* PTR TO NODE FOR LAST GENERATED PROC *)
 346       level : levrange ;
 347       liglues : integer ;                         (* TOTAL  READ LINES COUNTER *)
 348 
 349       linkswordcount : integer ;                  (* WORD COUNT FOR LINKS GENERATION *)
 350       listyes : boolean ;                         (*  TRUE IF LISTING REQUE STED *)
 351       longchaine : integer ;                      (* LGTH USED IN BUFVAL *)
 352       longprofile : boolean ;                     (* TRUE IF LONG_PROFILE OPTION *)
 353       longstring : integer ;                      (*  LENGTH OF STRING IN CONALFA  *)
 354       majmin : ARRAY [0..127] OF integer ;
 355       mapswitch : boolean ;                       (* TRUE IF STATEMEMNT MAP NEEDED *)
 356       maxstring_ptr : ctp ;                       (* PTR TO MAXSTRING PREDEFINED CONSTANT *)
 357       mpcogerr, mpcogin, mpcogout : text ;
 358       next : ctp ;                                (*  LAST ITEM IN CONTTEXTTABLE *)
 359                                                   (* (NOT ALLWAYS) *)
 360       nilptr : ctp ;                              (*  NIL POINTER TYPE POINTER *)
 361       no : integer ;                              (* OUTPUT OF  IN SYMBOL  *)
 362       no_compilation_warnings : boolean ;
 363       outputflag : ptexternalitem ;               (* #0 IF OUTPUT IS IN PRG. PARAM. *)
 364       pageserrors : ARRAY [0..maxerpg] OF SET OF 0..maxset ; (* TO KEEP PAGES  *)
 365       pascalfrench : boolean ;
 366       pnumptr : ctp ; (* NUM. SET  TYPE POINTER *) (* WHERE ARE ERRS *)
 367       profilewordcount : integer ;                (* TOTAL PROFILE COUNTERS WORD COUNT *)
 368       profptr : profareaptr ;                     (* PTR TO PROFILE COUNTERS GENERATION AREA *)
 369       progname : alfaid ;                         (* NAME OF PRG.; FILLED IN PROGDECL *)
 370       programnode : blocknodeptr ;                (* PTR TO FIRST NODE OF PROGRAM *)
 371       realptr : ctp ;                             (* REAL TYPE POINTER *)
 372       rval : real ;                               (* OUTPUT  OF INSYMBOL *)
 373       selectivetable : boolean ;                  (* TRUE IF SOME SYMBOL TABLES REQUIRED *)
 374       sourceindex : integer ;                     (* INDEX IN SOURCE STRING *)
 375       sourcenbr : integer ;                       (* CURRENT SOURCE NO *)
 376       startic : integer ;                         (* INDEX OF FIRST NON PROFILE INSTR OF CURR STTMT *)
 377       staticswordcount : integer ;                (* TOTAL STATICS WORD COUNT *)
 378       statnbr : integer ;                         (* TOTAL NBR OF STATEMENTS IN STT MAP *)
 379       string_ptr : ctp ;                          (* PTR TO STANDARD STRING FORMAT *)
 380       sttfile : integer ;                         (* FILE NO OF CURR STTMT *)
 381       sttindex : integer ;                        (* INDEX IN SOURCE OF CURR STTMT *)
 382       sttline : integer ;                         (* LINE NO OF CURR STTMT *)
 383       sttplace : integer ;                        (* LOC FOR CURRENT STATEMENT *)
 384       symbolfile : integer ;                      (* SOURCE FILE OF CURRENT SYMBOL *)
 385       symbolindex : integer ;                     (* INDEX IN SOURCE OF CURR SYMBOL *)
 386       symbolline : integer ;                      (* SOURCE LINE OF CURRENT SYMBOL *)
 387       symbolmap : boolean ;                       (* TRUE IF SYMBOLS MAP REQUESTED *)
 388       textfilectp : ctp ;                         (* TEXT FILE TYPE POINTER *)
 389       top : integer ;                             (* LAST USED ENTRY IN DISPLAY *)
 390       undecptr : ctp ;                            (* FOR UNDEFINED VARS *)
 391       undlab : ARRAY [1..undmax] OF occurence ;
 392                                                   (* USED TO KEEP SEVERAL LISTS *)
 393                                                   (* OF UNRESOLVED REFERENCES *)
 394       usednames : typusednames ;
 395       version : integer ;                         (* CURRENT RELEASE OF THE COMPILER *)
 396       xc : integer ;                              (*  COUNTER  FOR GLOBALS  *)
 397       xrefneed : boolean ;                        (*  TRUE IF CROSS REFERENCES USED *)
 398 
 399 (*  DEFINE INTERNALLY USED  VARIABLES *)
 400       adrligic : integer ;
 401       adrliglc : integer ;
 402                                                   (* USED IN ORDER TO PRINT COUNTERS *)
 403                                                   (* AT BEGINNING OF EACH LINE *)
 404       beginline : boolean ;                       (* TRUE IF READING BEGINNING OF SOURCE LINE *)
 405       brieftable : boolean ;                      (* TRUE IF BRIEF TABLE NEEDED *)
 406       bufold, bufnew : PACKED ARRAY [1..maxsliceline] OF char ;
 407       ch : char ;                                 (* OUTPUT OF NEXTCH, INPUT OF INSYMBOL *)
 408       chcnt : integer ;                           (* COLUMN NUMBER IN A SOURCE LINE *)
 409       checks : boolean ;                          (* INIT IN CARTEEXEC OR IN MAIN *)
 410       column : integer ;                          (* CURRENT COLUMN IN SOURCE LINE *)
 411       compencours : boolean ;
 412       currdate : alfa ;                           (* CURRENT DATE  DD**MM**YY   *)
 413       cursttmap : sttmapptr ;                     (* PTR TO CURRENT STT MAP STRUCTURE *)
 414       digits : SET OF char ;                      (* 0..9 *)
 415       dpoint : boolean ;
 416       end_statement : boolean ;                   (* TRUE IF STTMAP HAS BEEN GENERATED FOR CURR STT *)
 417       erredited : ARRAY [0..maxerpg] OF SET OF 0..maxset ;
 418       errinx : integer ;
 419       errlist : ARRAY [1..maxerrline] OF
 420       RECORD
 421         pos, nmr : integer ;                      (* TO KEEP ERR NUMBERS AND POSITIONS *)
 422       END ;
 423       err257 : boolean ;
 424                                                   (*  FLAG  FOR A LINE TOO LONG *)
 425       err149 : boolean ;                          (* FLAG *)
 426       filetoprint : integer ;                     (* FILE NBR TO PRINT AT THE BEGINNING OF A SOURCE LINE *)
 427       iligne : integer ;                          (* COUNTER OF LINES ON A PAGE *)
 428       instring : boolean ;                        (* TRUE IF IN A STRING *)
 429                                                   (* IN INSYMBOL AND NEXTCH *)
 430       incomment : boolean ;                       (* TRUE IF IN A COMMENT *)
 431       lastfile : integer ;                        (* FILE OF LAST EDITED LINE ON ERROR FILE *)
 432       lastlig : integer ;                         (* LAST EDITED LINE ON ERROR FILE *)
 433       letters : SET OF char ;
 434       linetoprint : integer ;                     (* LINE NBR TO PRINT AT THE BEGINNING OF A SOURCE LINE *)
 435       longpad : integer ;                         (*   ''      "     IN BUFVAL  *)
 436       mapptr : sttmapptr ;                        (* PTR TO STATEMENT MAP GENERATION AREA *)
 437       nbccond : integer ;                         (*  NESTED  CONDITIONAL COMP   *)
 438       oldfile : integer ;                         (* FILE OF PREVIOUS STATEMENT *)
 439       oldic : integer ;                           (* IC OF PREVIOUS STATEMENT *)
 440       oldindex : integer ;                        (* INDEX OF OLD STATEMENT MAP *)
 441       oldline : integer ;                         (* LINE OF PREVIOUS STATEMENT *)
 442       pagelength : integer ;                      (* INIT BY MAXPAGELINE OR CARTEEXEC *)
 443       pageno : integer ;                          (* NUMBER OF CURRENT PAGE *)
 444       pos1 : integer ;                            (* LAST ERROR'S POSITION IN LINE *)
 445       prevfile : integer ;                        (* FILE OF PREVIOUS LINE *)
 446       prevlig : integer ;                         (* LIEN NO OF PREVIOUS LINE *)
 447       profile : boolean ;                         (* TRUE IF PROFILE OPTION *)
 448       pt : ctp ;                                  (*  WORK  POINTER *)
 449       skipcode : boolean ;                        (* IF TRUE THEN DONT COMPILE SOURCE *)
 450       skippage : boolean ;                        (* TRUE ALTER $PAGE *)
 451 
 452       sourcectx : char ;                          (* '*' if line begins in a comment, ' 'otherwise *)
 453       sttinline : integer ;                       (* NBR OF STATEMENT IN LINE *)
 454       symbline : PACKED ARRAY [0..maxlinepascal] OF char ; (* CHARS OF A SOURCE LINE *)
 455       symbol_listing : boolean ;                  (* TRUE IF CROSS REFERENCE OF SYMBOLS ON LISTING *)
 456       symcl : ARRAY [0..127] OF integer ;         (*  CL  FOR  EACH  PASCAL  0..127 *)
 457       symno : ARRAY [0..127] OF integer ;         (*  NO   "     "     "       "  *)
 458       rversion : integer ;                        (* VERSION OF RACINE *)
 459       tsetinargs : boolean ;                      (* TRUE IF T OPTION SET AT COMMAND LEVEL *)
 460       usednamesa,
 461       usednamesf : typusednames ;
 462       wcl,
 463       wcla,
 464       wclf : ARRAY [0..maxnbofkeywords] OF integer ;
 465       wd,
 466       wda,
 467       wdf : ARRAY [0..maxnbofkeywords] OF alfaid ;
 468       wkextpt : ptexternalitem ;
 469       wl1,
 470       wl1a,
 471       wl1f : ARRAY [1..maxkeylength] OF integer ;
 472       wl2,
 473       wl2a,
 474       wl2f : ARRAY [1..maxkeylength] OF integer ;
 475       wno,
 476       wnoa,
 477       wnof : ARRAY [0..maxnbofkeywords] OF integer ;
 478       wnoset : setofno ;
 479       wdsetinargs : boolean ;                     (* TRUE IF WD OPTION SET AT COMMAND LEVEL *)
 480       wgsetinargs : boolean ;                     (* TRUE IF WG OPTION SET AT COMMAND LEVEL *)
 481       wssetinargs : boolean ;                     (* TRUE IF WS OPTION SET AT COMMAND LEVEL *)
 482 
 483 (*  KEY-WORD XXX IS  IN WD AT   ENTRY  "N"  OF  LENGTH   I
 484    WNO[N],WCL[N]   ARE  ASSOCIATED NO  AND CL
 485    ALL KEY WORDS OF  LENGTH I   ARE IN WD   BETWEEN  ENTRIES
 486    WL1[I] .. WL2[I]
 487    *)
 488 
 489 
 490 $OPTIONS page $
 491 
 492     $VALUE
 493       errcl = (16 * irrelsy,
 494         endsy,                                    (* 16  ;       *)
 495         4 * irrelsy,
 496         begsy,                                    (* 21  BEGIN   *)
 497         endsy,                                    (* 22  END     *)
 498         begsy,                                    (* 23  IF      *)
 499         irrelsy,                                  (* THEN *)
 500         endsy,                                    (* 25  ELSE    *)
 501         begsy,                                    (* 26  CASE    *)
 502         irrelsy,                                  (* OF  *)
 503         begsy,                                    (* 28  REPEAT  *)
 504         endsy,                                    (* 29 until *)
 505         begsy,                                    (* 30  WHILE   *)
 506         irrelsy,                                  (* DO   *)
 507         begsy,                                    (* 32  FOR     *)
 508         2 * irrelsy,                              (* TO DOWNTO *)
 509         begsy,                                    (* 35  GOTO    *)
 510         irrelsy,                                  (* 36  nil    *)
 511         endsy,                                    (* 37  TYPE    *)
 512         irrelsy,                                  (* 38 array record file set *)
 513         irrelsy,                                  (* 39 ..   *)
 514         2 * endsy,                                (* 40  LABEL  41  CONST *)
 515         irrelsy,                                  (* PACKED *)
 516         3 * endsy,                                (* 43  VAR  44  FUNCTION  45  PROCEDURE *)
 517         2 * irrelsy,
 518         begsy,                                    (* 48  WITH *)
 519         irrelsy,
 520         endsy,                                    (* 50  PROGRAM  *)
 521         7 * endsy) (* 51 $RENAME  52  $IMPORT  53  $EXPORT  54  $VALUE  55  $  *) ;
 522       majmin = (0, 1, 2, 3, 4, 5, 6, 7, 8, 32 (* SPACE *), 10, 11, 12, 13, 14, 15,
 523         16, 17, 18, 19, 20, 21, 22, 23, 24, 25,
 524         26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
 525         48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64,
 526                                                   (* MAJ TO MIN *)
 527         97, 98, 99, 100, 101, 102, 103, 104, 105, 106,
 528         107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117,
 529         118, 119, 120, 121, 122,
 530                                                   (* now same order *)
 531         91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102,
 532         103, 104, 105, 106, 107, 108, 109, 110, 111, 112,
 533         113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127) ;
 534       symcl = (35 * 0, 5, 6 * 0, 1, 1, 0, 2, 0, 2, 12 * 0, 1, 6, 4, 65 * 0) ;
 535       symno = (35 * 0, 8, 4 * 0, 9, 10, 6, 7, 15, 7, 17, 6, 10 * 0,
 536         19, 16, 3 * 8, 0, 18, 26 * 0, 11, 0, 12, 18,
 537         33 * 0) ;
 538       usednamesa = ('input', 'output', 'error', 'forward', 'external', 'otherwise'
 539         ) ;
 540       usednamesf = ('entree', 'sortie', 'erreur', 'plusloin', 'externe', 'autrement'
 541         ) ;
 542       wcla = (0,
 543         0, 0, 1, 0, 7, 3,
 544         0, 0, 0, 4, 5, 0,
 545         3, 1, 4,
 546         0, 0, 0, 0, 0, 0,
 547         3,
 548         0, 0, 0, 1,
 549         0, 0,
 550         0, 2, 2, 0, 0,
 551         0, 0, 0, 0,
 552         0, 0, 0,
 553         0) ;
 554       wclf = (
 555         0,
 556         0, 3, 3, 0,
 557         2, 0, 4, 0, 5, 0, 1, 0,
 558         0, 7, 1, 0, 0,
 559         0, 0, 0, 0, 0,
 560         0, 0, 0,
 561         2, 3, 0, 1, 0, 0, 0,
 562         4, 0, 0, 0, 0, 0,
 563         0, 0, 0
 564         ) ;
 565       wda = ('$       ',
 566         'if      ', 'do      ', 'to      ', 'of      ', 'in      ', 'or      ',
 567         'end     ', 'nil     ', 'for     ', 'div     ', 'mod     ', 'var     ',
 568         'and     ', 'not     ', 'set     ',
 569         'then    ', 'else    ', 'goto    ', 'case    ', 'with    ', 'type    ',
 570         'file    ',
 571         'begin   ', 'until   ', 'while   ', 'array   ',
 572         'const   ', 'label   ',
 573         'repeat  ', 'downto  ', 'record  ', 'packed  ', '$value  ',
 574         'program ', '$rename ', '$import ', '$export',
 575         'function', '$include', '$options',
 576         'procedure') ;
 577       wdf = (
 578         '$ ',
 579         'de', 'et', 'ou', 'si',
 580         'bas', 'cas', 'div', 'fin', 'mod', 'nil', 'non', 'var',
 581         'avec', 'dans', 'haut', 'pour', 'type',
 582         'alors', 'const', 'debut', 'faire', 'sinon',
 583         'allera', 'jusque', 'paquet',
 584         'article', 'fichier', 'repeter', 'tableau', 'tantque', '$valeur', '$rename',
 585         'ensemble', 'fonction', '$exporte', '$importe', '$include', '$options',
 586         'etiquette', 'procedure', 'programme'
 587         ) ;
 588       wl1a = (0, 1, 7, 16, 23, 29, 34, 38, 41) ;
 589       wl1f = (0, 1, 5, 13, 18, 23, 26, 33, 39) ;
 590       wl2a = (0, 6, 15, 22, 28, 33, 37, 40, 41) ;
 591       wl2f = (0, 4, 12, 17, 22, 25, 32, 38, 41) ;
 592       wnoa = (55,
 593         23, 31, 33, 27, 8, 7,
 594         22, 36, 32, 6, 6, 43,
 595         6, 5, 38,
 596         24, 25, 35, 26, 48, 37,
 597         38,
 598         21, 29, 30, 38,
 599         41, 40,
 600         28, 33, 38, 42, 54,
 601         50, 51, 52, 53,
 602         44, 56, 57,
 603         45) ;
 604       wnof = (
 605         55,
 606         27, 6, 7, 23,
 607         33, 26, 6, 22, 6, 36, 5, 43,
 608         48, 8, 33, 32, 37,
 609         24, 41, 21, 31, 25,
 610         35, 29, 42,
 611         38, 38, 28, 38, 30, 54, 51,
 612         38, 44, 53, 52, 56, 57,
 613         40, 45, 50
 614         ) $
 615 
 616 
 617 $OPTIONS page $
 618 
 619 (* IMPORTED   FROM   "UNIQUE"  *)
 620     PROCEDURE initialise ; EXTERNAL ;
 621     PROCEDURE progdecl ; EXTERNAL ;
 622     PROCEDURE initclasse ; EXTERNAL ;
 623     PROCEDURE heaperror ; EXTERNAL ;
 624     PROCEDURE prterrmeans (VAR ff : text ; numerr : integer) ; EXTERNAL ;
 625     PROCEDURE statistiques ; EXTERNAL ;
 626     PROCEDURE displaysymbols ; EXTERNAL ;
 627 
 628 (* IMPORTED  FROM "DECLARE" *)
 629     PROCEDURE body (surrptr, firstentry : ctp) ; EXTERNAL ;
 630 
 631 (* IMPORTED FROM CONTEXTTABLE *)
 632 
 633     PROCEDURE create_vars_box (VAR fvbox : ctp ; fname : alfaid) ; EXTERNAL ;
 634     PROCEDURE create_dummyclass_box (VAR fvbox : ctp ; fname : alfaid) ; EXTERNAL ;
 635 
 636 
 637 (* IMPORTED FORM "GENERE"      *)
 638     PROCEDURE genprofileref ; EXTERNAL ;
 639     PROCEDURE genlongprofileref ; EXTERNAL ;
 640     PROCEDURE inser (fcb, fplace : integer) ; EXTERNAL ;
 641     PROCEDURE listhead ; EXTERNAL ;
 642 
 643 
 644 (* IMPORTED FROM STATE *)
 645     PROCEDURE freeallregisters ; EXTERNAL ;
 646 
 647 (* IMPORTED FROM EXPR *)
 648     PROCEDURE expression ; EXTERNAL ;
 649 
 650 (* IMPORTED FROM MODATTR *)
 651     PROCEDURE initattrvarbl (VAR fattr : attr) ; EXTERNAL ;
 652 
 653 (* IMPORTED FROM PL1 *)
 654 
 655     PROCEDURE buildobject ; EXTERNAL ;
 656     PROCEDURE initsource ; EXTERNAL ;
 657     PROCEDURE beginsource
 658         (filename : externid ; stringdeb : alfaid ; ldeb : integer ; stringfin : alfaid ; lfin : integer) ; EXTERNAL ;
 659     PROCEDURE endsource ; EXTERNAL ;
 660     PROCEDURE displaysources ; EXTERNAL ;
 661                                                   (* FROM PL1   *)
 662     PROCEDURE geninput (pr4disp : integer ; VAR fret : integer) ; EXTERNAL ;
 663     PROCEDURE genoutput (pr4disp : integer ; VAR fret : integer) ; EXTERNAL ;
 664     PROCEDURE generror (pr4disp : integer ; VAR fret : integer) ; EXTERNAL ;
 665     PROCEDURE genentree (pr4disp : integer ; VAR fret : integer) ; EXTERNAL ;
 666     PROCEDURE gensortie (pr4disp : integer ; VAR fret : integer) ; EXTERNAL ;
 667     PROCEDURE generreur (pr4disp : integer ; VAR fret : integer) ; EXTERNAL ;
 668 
 669     PROCEDURE getmapptr (VAR mapptr : sttmapptr) ; EXTERNAL ;
 670     PROCEDURE getprofptr (VAR profptr : profareaptr) ; EXTERNAL ;
 671     PROCEDURE convertreal (string : numberstring ; exp : integer ; VAR reel : real) ; EXTERNAL ;
 672 
 673 
 674     PROCEDURE geninputlink (pr4disp : integer ; VAR fret : integer) ;
 675 
 676       BEGIN
 677         IF pascalfrench THEN
 678           genentree (pr4disp, fret) ELSE
 679           geninput (pr4disp, fret) ;
 680       END ;
 681 
 682 
 683     PROCEDURE genoutputlink (pr4disp : integer ; VAR fret : integer) ;
 684 
 685       BEGIN
 686         IF pascalfrench THEN
 687           gensortie (pr4disp, fret) ELSE
 688           genoutput (pr4disp, fret) ;
 689       END ;
 690 
 691 
 692     PROCEDURE generrorlink (pr4disp : integer ; VAR fret : integer) ;
 693 
 694       BEGIN
 695         IF pascalfrench THEN
 696           generreur (pr4disp, fret) ELSE
 697           generror (pr4disp, fret) ;
 698       END ;
 699 
 700 
 701 (* ********************************************************** NEXTPAGE  ******* *)
 702 
 703     PROCEDURE nextpage ; FORWARD ;
 704 
 705 
 706 $OPTIONS page $
 707 
 708 (* *************************************   INITRACINE   *********************** *)
 709 
 710     PROCEDURE initracine ;
 711 
 712 (* C     THIS PROCEDURE IS USED TO INITIALIZE THE GLOBALS OF RACINE AND IS
 713    CALLED IN THE MODULE UNIQUE (PROCEDURE INITILALISE)                  C *)
 714       VAR
 715         it : integer ;
 716       BEGIN                                       (* INITRACINE *)
 717         adrligic := 0 ; adrliglc := 0 ;
 718         anytrace := none ;
 719         beginline := false ;
 720         bufold := '  ' ; bufnew := '   ' ;
 721         rewrite (mpcogerr) ;
 722         reset (mpcogin) ;
 723         initsource ;
 724         brieftable := false ;
 725         ch := ' ' ;
 726         chcnt := 0 ;
 727         check_id := false ;
 728         chnix := 1 ;
 729         codelist := false ;
 730         column := 0 ;
 731         compencours := true ;
 732         cursttmap := NIL ;
 733         date (currdate) ;
 734         declarationpart := true ;
 735         digits := ['0'..'9'] ;
 736         FOR it := 0 TO displimit DO
 737           display [it].fname := NIL ;             (* FOR SECURITY *)
 738         dpoint := false ;
 739         end_statement := true ;
 740         environt := data ;
 741         errinx := 0 ; fastoperator := false ;
 742         errorflag := NIL ;
 743         exportablecode := false ;
 744         extcalltrapplace := 0 ;
 745         FOR it := 0 TO maxerpg DO
 746           BEGIN
 747             pageserrors [it] := [] ;
 748             errorsfound [it] := [] ;
 749             erredited [it] := [] ;
 750           END ;
 751         errtotal := 0 ;
 752         err257 := false ;
 753         filetoprint := 0 ;
 754                                                   (* firstcond IS SET IN pascal COMMAND BEFORE CALL TO racine *)
 755         iligne := 0 ;
 756         init_fsb_trap_flag := false ;
 757         init_fsb_trap_info_place := 0 ;
 758         init_fsb_trap_links_place := 0 ;
 759         init_fsb_trap_number_of_files := 0 ;
 760         inputflag := NIL ;
 761         interactive := false ;
 762         iowarnings := true ;
 763         envstandard := stdpure ;
 764         instring := false ;
 765         lastfile := 0 ;
 766         lastlig := 0 ;
 767         lastproc := NIL ;
 768         letters := ['a'..'z', 'A'..'Z'] ;
 769         incomment := false ;
 770         liglues := 1 ;
 771         linetoprint := 1 ;
 772         next := NIL ;
 773         level := 0 ;
 774         longpad := maxval ;
 775         longprofile := false ;
 776         mapptr := NIL ;
 777         mapswitch := false ;
 778         maxstring_ptr := NIL ;
 779         nbccond := 0 ;
 780         oldfile := -1 ;
 781         oldindex := 0 ;
 782         oldline := 0 ;
 783         outputflag := NIL ;
 784         pageno := 0 ; pagelength := maxpageline ; (* DEFAULT *)
 785         pascalfrench := false ;
 786         pos1 := 0 ;
 787         prevfile := 0 ;
 788         prevlig := 0 ;
 789         profile := false ;
 790         profilewordcount := 0 ;
 791         profptr := NIL ;
 792         progname := blank ;
 793         programnode := NIL ;
 794         rversion := 0 ;
 795         selectivetable := false ;
 796         string_ptr := NIL ;
 797         sourceindex := -1 ;
 798         version := rversion ;
 799         skipcode := false ; skippage := false ;
 800         sourcectx := ' ' ;
 801         sourcenbr := 0 ;
 802         startic := -1 ;
 803         statnbr := 0 ;
 804         symbol_listing := false ;
 805         symbolmap := false ;
 806         top := 0 ;
 807         FOR it := 1 TO undmax - 1 DO
 808           undlab [it].succ := it + 1 ;
 809         undlab [undmax].succ := 0 ;
 810         wnoset := [5, 6, 7, 8, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 35, 36, 37, 38, 40, 41, 42, 43, 44, 45, 48, 50] ;
 811         wdsetinargs := false ;
 812         wgsetinargs := false ;
 813         wssetinargs := false ;
 814         xc := firstglobal * bytesinword ;
 815         xrefneed := false ;
 816         FOR it := 1 TO 120 DO boxheader [it] := '*' ;
 817       END (* INITRACINE *) ;
 818 
 819 
 820 $OPTIONS page $
 821 
 822 (* *************************************NEXTLINE******************************* *)
 823 
 824     PROCEDURE nextline ;
 825 
 826 (* C   PRINTS THE CURRENT LINE (WRITELN)
 827    BUFFER OF OUTPUT  MUST BE FILLED BEFORE                                  C *)
 828       BEGIN
 829         IF listyes THEN writeln (mpcogout) ;
 830         iligne := iligne + 1 ;                    (* NUMBER OF LINES  IN  CURRENT  PAGE *)
 831         IF skippage OR (iligne >= pagelength) THEN nextpage ;
 832       END (* NEXTLINE *) ;
 833 
 834 
 835 
 836 
 837 $OPTIONS page $
 838 
 839 (* *******************************************************  RETURNSTOP   ****** *)
 840 
 841     PROCEDURE returnstop ;
 842 
 843 (* C  THIS PROCEDURE IS CALLED BY HEAPERROR (IN UNIQUE) IN ORDER TO STOP
 844    THE COMPILATION                                                        C *)
 845       BEGIN
 846         GOTO 100 ;                                (* END OF COMPILATION. HEAP IS FULL *)
 847       END (* RETURNSTOP *) ;
 848 
 849 
 850 $OPTIONS page $
 851 
 852 (* *********************************************************ERROR************** *)
 853 
 854     PROCEDURE error (errno : integer) ;
 855 
 856 (* C  ENTERS  .NEW ERROR IN ERRLIST (FOR EACH LINE)
 857    .NEW ERROR IN ERRORSFOUND (FOR END OF COMPILATION MEANINGS)
 858    .LISTING'S PAGE NUMBER IN PAGEERRORS                            C *)
 859 (* E  ERRORS DETECTED
 860    255: TOO MANY ERRORS ON THIS LINE
 861    381: ERROR NUMBER EXCEED HIGH BOUND
 862    382: PAGE  NUMBER   "      "    "                                      E *)
 863       BEGIN
 864 $OPTIONS compile = trace $
 865         IF anytrace > none THEN
 866           BEGIN
 867             write (mpcogout, ' @@@ DEBUT ERROR WITH ERRNO ', errno : 5) ; nextline ;
 868             IF anytrace = high THEN
 869               BEGIN
 870                 write (mpcogout, ' ERRINX,POS1,COLUMN ', errinx, pos1, column) ; nextline ;
 871               END
 872           END ;
 873 $OPTIONS compile = true $
 874         IF errinx = (maxerrline - 1) THEN
 875           errno := 255 ;                          (* TOO MANY ERRORS *)
 876         IF errinx < maxerrline THEN
 877           BEGIN
 878             IF column > pos1 THEN pos1 := column ;
 879             errinx := errinx + 1 ;
 880             WITH errlist [errinx] DO
 881               BEGIN pos := pos1 ; nmr := errno ;
 882               END ;
 883             pos1 := pos1 + 1 ;
 884 $OPTIONS compile = security $
 885             IF errno > maxerrnum THEN error (381) ELSE
 886 $OPTIONS compile = true $
 887               errorsfound [errno DIV setrange] := errorsfound [errno DIV setrange] +
 888               [errno MOD setrange] ;
 889 $OPTIONS compile = security $
 890             IF pageno > maxpage THEN error (382) ELSE
 891 $OPTIONS compile = true $
 892               pageserrors [pageno DIV setrange] := pageserrors [pageno DIV setrange] +
 893               [pageno MOD setrange] ;
 894             errtotal := errtotal + 1 ;
 895           END ;
 896 $OPTIONS compile = trace $
 897         IF anytrace > low THEN
 898           BEGIN
 899             IF anytrace = high THEN
 900               BEGIN
 901                 write (mpcogout, ' NOW  ERRINX, POS1 ARE ', errinx, pos1) ; nextline ;
 902               END ;
 903             write (mpcogout, ' @@@ FIN  ERROR @@@ ') ; nextline ;
 904           END ;
 905 $OPTIONS compile = true $
 906       END (* ERROR *) ;
 907 
 908 
 909 $OPTIONS page $
 910 
 911 (* *******************************************  WARNING   ************** *)
 912 
 913     PROCEDURE warning (errno : integer) ;
 914 
 915 (* C  ENTERS  .NEW WARNING IN ERRLIST (FOR EACH LINE)
 916    .NEW WARNING IN ERRORSFOUND (FOR END OF COMPILATION MEANINGS)
 917    .LISTING'S PAGE NUMBER IN PAGEERRORS
 918 
 919    EXACTLY THE CONTENTS OF the procedure ERROR , EXCEPT
 920    ERRTOTAL' INCREMENT      .
 921    C *)
 922 (* E  ERRORS DETECTED
 923    255: TOO MANY ERRORS ON THIS LINE
 924    381: ERROR NUMBER EXCEED HIGH BOUND
 925    382: PAGE  NUMBER   "      "    "                                      E *)
 926       BEGIN
 927 $OPTIONS compile = trace $
 928         IF anytrace > none THEN
 929           BEGIN
 930             write (mpcogout, ' @@@ DEBUT WARNING WITH ERRNO ', errno : 5) ; nextline ;
 931             IF anytrace = high THEN
 932               BEGIN
 933                 write (mpcogout, ' ERRINX,POS1,COLUMN ', errinx, pos1, column) ; nextline ;
 934               END
 935           END ;
 936 $OPTIONS compile = true $
 937 
 938         IF NOT no_compilation_warnings THEN
 939           BEGIN
 940             IF errinx = (maxerrline - 1) THEN
 941               errno := 255 ;                      (* TOO MANY ERRORS *)
 942             IF errinx < maxerrline THEN
 943               BEGIN
 944                 IF column > pos1 THEN pos1 := column ;
 945                 errinx := errinx + 1 ;
 946                 WITH errlist [errinx] DO
 947                   BEGIN pos := pos1 ; nmr := errno ;
 948                   END ;
 949                 pos1 := pos1 + 1 ;
 950 $OPTIONS compile = trace $
 951                 IF errno > maxerrnum THEN error (381) ELSE
 952 $OPTIONS compile = true $
 953                   errorsfound [errno DIV setrange] := errorsfound [errno DIV setrange] +
 954                   [errno MOD setrange] ;
 955 $OPTIONS compile = trace $
 956                 IF pageno > maxpage THEN error (382) ELSE
 957 $OPTIONS compile = true $
 958                   pageserrors [pageno DIV setrange] := pageserrors [pageno DIV setrange] +
 959                   [pageno MOD setrange] ;
 960                                                   (*         NO INCREMENT OF ERRTOTAL      *)
 961               END ;
 962           END ;
 963 $OPTIONS compile = trace $
 964         IF anytrace > low THEN
 965           BEGIN
 966             IF anytrace = high THEN
 967               BEGIN
 968                 write (mpcogout, ' NOW  ERRINX, POS1 ARE ', errinx, pos1) ; nextline ;
 969               END ;
 970             write (mpcogout, ' @@@ FIN  WARNING @@@ ') ; nextline ;
 971           END ;
 972 $OPTIONS compile = true $
 973       END (* WARNING *) ;
 974 
 975 
 976 $OPTIONS page $
 977 
 978 (* ***********************************************NEXTPAGE********************* *)
 979 
 980     PROCEDURE nextpage ;
 981 
 982 (* C NEXTLINE ON OUTPUT BEGINS AT BEGINNING OF A NEW PAGE  ON LISTING
 983    INCREMENTS    PAGENO;
 984    PRINTS        PAGE  NUMBER
 985    C *)
 986 (* E  ERRORS DETECTED
 987    383:  MAX NUMBER OF LISTING'S PAGES EXCEEDED                             E *)
 988       BEGIN
 989         skippage := false ;
 990         pageno := pageno + 1 ;
 991 $OPTIONS compile = trace $
 992         IF pageno > maxpage THEN error (383) ;
 993 $OPTIONS compile = true $
 994         IF listyes THEN page (mpcogout) ;         (* NEXT LINE ON A NEW PAGE(MPCOGOUT) *)
 995                                                   (* WRITE    PAGE NUMBER *)
 996         IF listyes THEN
 997           write (mpcogout, '*** MULTICS PASCAL COMPILER - V8.0', version : 1,
 998             '  **** PROGRAM ', progname : 32,
 999             ' *** ON ', currdate, ' *** ', ' ' : 11,
1000             'PAGE ', pageno : 5) ;
1001         iligne := 0 ;
1002         nextline ;
1003                                                   (* DUMMY SPACE LINE *)
1004         nextline ;
1005                                                   (* INIT  COUNTER  FOR ALLOWED LINES *)
1006                                                   (* ON A PAGE *)
1007       END (* NEXTPAGE *) ;
1008 
1009 
1010 $OPTIONS page $
1011 
1012 (* ***********************************************(FCT) SUP******************** *)
1013 
1014     FUNCTION sup (fval1, fval2 : integer) : integer ;
1015 
1016 (* C SUP IS THE GREATEST  VALUE BETWEEN  FVAL1 AND FVAL2                      C *)
1017       BEGIN
1018         IF fval1 > fval2 THEN
1019           sup := fval1 ELSE
1020           sup := fval2 ;
1021       END (* SUP *) ;
1022 
1023 
1024 $OPTIONS page $
1025 
1026 (* ************************************ FCT. POWEROFTWO *********************** *)
1027     FUNCTION poweroftwo (fval : integer) : integer ;
1028 
1029 (* C  RETURNS   N  IF  FVAL=2**N
1030    -1  IF  FVAL <=0
1031    0  IF  FVAL= 1
1032    C *)
1033       LABEL
1034         10 ;                                      (* EXIT LOOP *)
1035       VAR
1036         lvalu, it : integer ;
1037       BEGIN                                       (* POWEROFTWO *)
1038         IF fval <= 0 THEN
1039                                                   (* <==== *) lvalu := -1 ELSE
1040           FOR it := 0 TO bitsinword - 2 DO
1041             IF fval = 1 THEN
1042               BEGIN
1043                 (* <==== *) lvalu := it ; GOTO 10 ; (* EXITLOOP *)
1044               END (* FVAL=1 *) ELSE
1045               IF odd (fval) THEN
1046                 BEGIN
1047                   (* <==== *) lvalu := -1 ; GOTO 10 ; (* EXIT LOOP *)
1048                 END (* ODD *) ELSE
1049                 fval := fval DIV 2 ;
1050 10 :                                              (* EXIT LOOP *)
1051         poweroftwo := lvalu ;
1052 $OPTIONS compile = trace $
1053         IF anytrace > none THEN
1054           BEGIN
1055             write (mpcogout, '@@@ DEBUT-FIN POWEROFTWO @@@ WITH FVAL, COMPUTED VALUE',
1056               fval, lvalu) ;
1057             nextline ;
1058           END ;
1059 $OPTIONS compile = true $
1060       END (* POWEROFTWO *) ;
1061 
1062 
1063 $OPTIONS page $
1064 
1065 (* ************************************ INSERUNDLAB *************************** *)
1066 
1067     PROCEDURE inserundlab (fcb, fdebchain : integer) ;
1068 
1069 (* C   "FCB"   IS A  BYTES DISPLACEMENT IN THE CODE FOR THE ACTUAL PROCEDURE.
1070    "FDEBCHAIN"  IS  THE  BEGINNING  IN UNDLAB   OF  A LIST  OF UNRESOLVED
1071    REFERENCES  USING  THIS VALUE  OF "FCB".
1072    EACH ITEM  OF  THE  LIST  IS
1073    .THE PLACE   IN CODE( IN FICHINTER)  OF  INCOMPLETE INSTRUCTION
1074    .THE POINTER ON THE NEXT LIST'S  ITEM
1075    C *)
1076 (* E ERRORS DETECTED
1077    407   FDEBCHAIN MUST NOT BE  0  (EMPTY LIST)
1078    E *)
1079       LABEL 1 ;                                   (* EXIT IF COMPILER'S ERROR *)
1080       VAR
1081         it : integer ;
1082       BEGIN                                       (* INSERUNDLAB *)
1083 $OPTIONS compile = trace $
1084         IF stattrace > none THEN
1085           BEGIN
1086             write (mpcogout, '@@@ DEBUT INSERUNDLAB @@@ WITH FCB,FDEBCHAIN', fcb, fdebchain : 6) ;
1087             nextline ;
1088           END ;
1089 $OPTIONS compile = true $
1090         IF fdebchain = 0 THEN
1091           BEGIN
1092             IF errtotal = 0 THEN error (407) ;
1093             GOTO 1 ;
1094           END ;
1095         it := fdebchain ;
1096         WHILE undlab [it].succ # 0 DO
1097           BEGIN
1098             inser (fcb, undlab [it].place) ;
1099             it := undlab [it].succ ;
1100           END ;
1101                                                   (*  NOW THE LAST *)
1102         inser (fcb, undlab [it].place) ;
1103                                                   (*  NOW  GIVE THIS  RESOLVED LIST *)
1104                                                   (* AT FREE LIST *)
1105         undlab [it].succ := chnix ;
1106         chnix := fdebchain ;
1107 $OPTIONS compile = trace $
1108         IF stattrace > low THEN
1109           BEGIN
1110             write (mpcogout, '@@@ FIN INSERUNDLAB @@@ WITH CHNIX:', chnix : 6) ; nextline ;
1111           END ;
1112 $OPTIONS compile = true $
1113 1 :                                               (* COMES HERE IF ERROR(407) *)
1114       END (* INSERUNDLAB *) ;
1115 
1116 
1117 
1118 $OPTIONS page $
1119 
1120 (* *********************************************************(FCT) RECADRE****** *)
1121 
1122     FUNCTION recadre (fnumber, fmod : integer) : integer ;
1123 
1124 (* C  RETURNS THE FIRST FMOD-MULTIPLE OF FNUMBER                              C *)
1125 (* E  ERRORS DETECTED
1126    350 :  RECADRE CALLED WITH  FMOD <=0
1127    E *)
1128       VAR
1129         lmod : integer ;
1130       BEGIN
1131 $OPTIONS compile = security $
1132         IF fmod <= 0 THEN
1133           error (350) ELSE
1134           BEGIN
1135 $OPTIONS compile = true $
1136             lmod := fnumber MOD fmod ;
1137             IF lmod = 0 THEN
1138               recadre := fnumber ELSE
1139               recadre := fnumber + fmod - lmod ;
1140 $OPTIONS compile = security $
1141           END ;
1142 $OPTIONS compile = true $
1143       END (* RECADRE *) ;
1144 
1145 
1146 
1147 $OPTIONS page $
1148 
1149 (* ***********************************************SRCHREC********************** *)
1150 
1151     PROCEDURE srchrec (fbegsearch : ctp) ; EXTERNAL ; (* THIS PROCEDURE HAS BEEN OPTIMIZED *)
1152 
1153 {
1154   OOPROCEDURE DEF SRCHREC (  FBEGSEARCH:CTP );
1155 
1156   CC(*C  SEARCHS A BOX WITH NAME= AVAL .  RETURNS   CTPTR = NIL  OR FOUND BOX
1157   SEARCH     BEGINS IN CONTEXTTABLE  AT  FBEGSEARCH   AND STOPS AT NIL
1158   C*)
1159   BBLABEL
1160   1 ; (* EXIT WHILE  FOR EFFICIENCY*)
1161   GGBEGIN
1162   CTPTR := FBEGSEARCH;
1163   WHILE  CTPTR # NIL DO
1164   IF  CTPTR@.NAME = AVAL THEN
1165   GOTO 1   ELSE
1166   CTPTR := CTPTR@.NXTEL;
1167   111: (* CTPTR HERE  NIL OR OK *)
1168   DDEND (*SRCHREC*) ;
1169 }
1170 
1171 
1172 $OPTIONS page $
1173 
1174 (* ***********************************************SEARCH*********************** *)
1175 
1176     PROCEDURE search ; EXTERNAL ;                 (* THIS PROCEDURE HAS BEEN OPTIMIZED *)
1177 
1178 {
1179   OOPROCEDURE DEF SEARCH;
1180 
1181   CC(*C   THE ARRAY 'DISPLAY'  FROM 0 TO TOP   CONTAINS  EACH  LEVEL'S LIST'S
1182   BEGINNING.
1183   THIS PROC  SEARCHS  A BOX WITH NAME 'AVAL'
1184   RETURNS   CTPTR = NIL  OR  FOUND BOX
1185   DISX  = INDEX  IN DISPLAY  WHERE  BOX  WAS  FOUND
1186   CAN BE 0  =>  PREDEF  OR  NOT FOUND
1187   C*)
1188   BBLABEL
1189   1; (* EXIT LOOP  FOR  EFFICIENCY  *)
1190   RRVAR
1191   I:INTEGER ;
1192   GGBEGIN
1193   FOR I:= TOP DOWNTO 0 DO
1194   BEGIN
1195   CTPTR := DISPLAY[I].FNAME; (* BEGINNING OF LIST *)
1196   WHILE CTPTR # NIL DO
1197   IF CTPTR@.NAME = AVAL THEN
1198   BEGIN
1199   DISX :=I; GOTO 1;
1200   END   ELSE
1201   CTPTR := CTPTR@.NXTEL;
1202   END;(*FOR I *)
1203   DISX := 0;
1204   111:  (* HERE   CTPTR AND DISX OK FOR CALLER *)
1205   DDEND (*SEARCH *);
1206 }
1207 
1208 
1209 $OPTIONS page $
1210 
1211 (* *************************************CREALFABOX***************************** *)
1212 
1213     PROCEDURE crealfabox (VAR fkonstbox : ctp) ;
1214 
1215 (* C .BUFVAL IS LOADED  FOR 1  TO LONGSTRING  WITH THE  STRING VALUE
1216    .THIS PROC   CREATES   THE  BOXES ASSOCIATED WITH THIS VALUE
1217    AND ASSIGNS  FKONSTBOX@.ALFADEB  AND  FKONSTBOX@.ALFALONG
1218    C *)
1219 (* E ERRORS   DETECTED
1220    HEAPERROR
1221    E *)
1222       VAR
1223         localfpt, nxtal : alfapt ;
1224         nboxes, it, j, longlast, debbuf : integer ;
1225 
1226 
1227 (* ***********************************************PRINTALFABOX < CREALFABOX**** *)
1228 
1229 $OPTIONS compile = trace $
1230       PROCEDURE printalfabox (ptalfabox : alfapt) ;
1231 
1232 (* C   USED IN CONDITIONAL  COMPILATION TO PRINT THE CONTENT OF
1233    AN ALFABOX (TYPE=ALFAVALUE). PTALFABOX POINTS THE BOX                  C *)
1234         VAR
1235           it : integer ;
1236         BEGIN
1237           nextline ; write (mpcogout, boxheader) ; nextline ;
1238           IF ptalfabox = NIL THEN
1239             BEGIN
1240               write (mpcogout, '* ALFABOX REQUESTED IS NIL. TRACE STOPS') ; nextline ;
1241             END ELSE
1242             BEGIN
1243               write (mpcogout, '* ALFABOX FOLLOWING IS AT @', ord (ptalfabox)) ; nextline ;
1244               WITH ptalfabox@ DO
1245                 BEGIN
1246                   write (mpcogout,
1247                     '*   NEXTVAL IS : ', ord (nextval), ' USED SIZE IS ', longfill : 4) ;
1248                   nextline ;
1249                   write (mpcogout, '*   ALFAVAL IS : @') ;
1250                   FOR it := 1 TO longfill DO write (mpcogout, alfaval [it]) ;
1251                   write (mpcogout, '@') ;
1252                   nextline ;
1253                 END ;                             (* WITH PTALFABOX@ *)
1254             END ;                                 (*  PTALFABOX # NIL *)
1255           write (mpcogout, boxheader) ; nextline ; nextline ;
1256         END (* PRINTALFABOX *) ;
1257 $OPTIONS compile = true $
1258 
1259 
1260       BEGIN                                       (* CREALFABOX *)
1261 $OPTIONS compile = trace $
1262         IF decltrace > none THEN
1263           BEGIN
1264             write (mpcogout, '@@@ DEBUT CREALFABOX @@@ ', 'V. FKONSTBOX ', ord (fkonstbox)) ;
1265             nextline ;
1266           END ;
1267 $OPTIONS compile = true $
1268         nboxes := longstring DIV longalfbox ;     (* NB. OF FULL BOXES *)
1269         longlast := longstring MOD longalfbox ;   (* LENGTH OF LAST BOX OR ZERO *)
1270         nxtal := NIL ;
1271         debbuf := 0 ;
1272         FOR it := 0 TO nboxes - 1 DO              (* FOR FULL  BOXES  *)
1273           BEGIN
1274             new (localfpt) ; IF localfpt = NIL THEN heaperror ; (* EXIT COMP *)
1275             IF nxtal = NIL THEN
1276               fkonstbox@.alfadeb := localfpt ELSE nxtal@.nextval := localfpt ;
1277             nxtal := localfpt ;
1278             WITH localfpt@ DO
1279               BEGIN nextval := NIL ;
1280                 FOR j := 1 TO longalfbox DO
1281                   alfaval [j] := bufval [debbuf + j] ;
1282                 debbuf := debbuf + longalfbox ;
1283                 longfill := longalfbox ;
1284               END ;
1285 $OPTIONS compile = trace $
1286             IF decltrace > none THEN
1287               BEGIN
1288                 write (mpcogout, ' ALFA BOX CREATED AT ', ord (localfpt)) ; nextline ;
1289                 IF decltrace = high THEN
1290                   printalfabox (localfpt) ;
1291               END ;
1292 $OPTIONS compile = true $
1293           END ;                                   (* FOR IT *)
1294         fkonstbox@.alfalong := longstring ;
1295         IF longlast # 0 THEN                      (* FILL   LAST BOX  *)
1296           BEGIN
1297             new (localfpt) ; IF localfpt = NIL THEN heaperror ; (* EXIT COMP *)
1298             IF nxtal = NIL THEN
1299               fkonstbox@.alfadeb := localfpt ELSE nxtal@.nextval := localfpt ;
1300             WITH localfpt@ DO
1301               BEGIN
1302                 nextval := NIL ; longfill := longlast ;
1303                 FOR j := 1 TO longlast DO
1304                   alfaval [j] := bufval [debbuf + j] ;
1305               END (* WITH *) ;
1306 $OPTIONS compile = trace $
1307             IF decltrace > none THEN
1308               BEGIN
1309                 write (mpcogout, ' ALFA BOX CREATED AT ', ord (localfpt)) ; nextline ;
1310                 IF decltrace = high THEN
1311                   printalfabox (localfpt) ;
1312               END ;
1313 $OPTIONS compile = true $
1314           END ;                                   (* LONGLAST #0 *)
1315 $OPTIONS compile = trace $
1316         IF decltrace > low THEN
1317           BEGIN
1318             IF decltrace = high THEN
1319               BEGIN
1320                 write (mpcogout, ' STRING TO BE GENERATED  ON ', longstring : 3, ' CHARS WAS') ;
1321                 nextline ;
1322                 FOR it := 1 TO longstring DO write (mpcogout, bufval [it]) ; nextline ;
1323               END ;
1324             write (mpcogout, ' @@@ FIN  CREALFABOX @@@') ; nextline ;
1325           END ;
1326 $OPTIONS compile = true $
1327       END (* CREALFABOX *) ;
1328 
1329 
1330 $OPTIONS page $
1331 
1332 (* *******************************************************************PRINTERR* *)
1333 
1334     PROCEDURE printerr ;
1335 
1336 (* C   AFTER  COMPILATION OF EACH PASCAL SOURCE LINE ,THIS PROCEDURE IS CALLED
1337    IN ORDER TO FLAG THE COLUMN(S) WHERE IS(ARE) ERROR(S)
1338    ERRINX POINTS THE LAST ENTRY USED IN ERRLIST WHERE NUMBER AND POSITION OF
1339    EACH ERROR IS KEPT                                                     C *)
1340       VAR
1341         it, errdeb, errmax, errptr, errnumb : integer ;
1342       BEGIN                                       (* PRINTERR *)
1343         errptr := 1 ;                             (* POINTS THE NEXT ERROR *)
1344                                                   (* TO BE PROCESSED *)
1345         errmax := 0 ;                             (* POINTS THE LAST COLUMN *)
1346                                                   (* REACHED ON A LINE *)
1347                                                   (* WRITES TWO LAST LINES *)
1348         IF (lastlig <> prevlig) OR (lastfile <> prevfile) THEN
1349           IF prevfile = 0 THEN writeln (mpcogerr, '    ', prevlig : 5, ' ', bufold)
1350           ELSE writeln (mpcogerr, prevfile : 3, ' ', prevlig : 5, ' ', bufold) ;
1351         IF filetoprint = 0 THEN writeln (mpcogerr, '    ', linetoprint : 5, ' ', bufnew)
1352         ELSE writeln (mpcogerr, filetoprint : 3, ' ', linetoprint : 5, ' ', bufnew) ;
1353         lastfile := filetoprint ; lastlig := linetoprint ;
1354         WHILE errptr <= errinx DO
1355           BEGIN
1356             errmax := errmax + lgprint ;
1357             IF errlist [errptr].pos <= errmax THEN
1358               BEGIN
1359                 IF chcnt <= lgprint THEN
1360                   BEGIN write (mpcogout, '*********') ;
1361                     write (mpcogerr, '*********') ;
1362                   END ELSE
1363                   BEGIN write (mpcogout, '***', (errmax DIV lgprint) : 3, '***') ;
1364                     write (mpcogerr, '***', (errmax DIV lgprint) : 3, '***') ;
1365                   END ;
1366                 errdeb := errptr ;                (* FIRST ERROR ON THE LINE PRINTED *)
1367                 FOR it := errmax - lgprint TO errmax DO
1368                   IF errptr <= errinx THEN
1369                     BEGIN
1370                       IF errlist [errptr].pos = it THEN
1371                         BEGIN
1372                           write (mpcogout, '"') ; write (mpcogerr, '"') ;
1373                           errptr := errptr + 1 ;
1374                         END ELSE
1375                         BEGIN write (mpcogout, ' ') ; write (mpcogerr, ' ') ;
1376                         END ;
1377                     END ELSE
1378                     BEGIN write (mpcogout, ' ') ; write (mpcogerr, ' ') ;
1379                     END ;
1380                 nextline ; writeln (mpcogerr) ;
1381               END ;                               (* ERROR(S) ON THE LINE *)
1382           END ;                                   (* LOOP ON THE LINES *)
1383         write (mpcogout, '  ERROR(S) NR :') ;
1384         write (mpcogerr, '  ERROR(S) NR :') ;
1385         FOR it := 1 TO errinx DO
1386           BEGIN
1387             write (mpcogout, errlist [it].nmr : 4) ;
1388             write (mpcogerr, errlist [it].nmr : 4)
1389           END ;
1390         nextline ; writeln (mpcogerr) ;
1391         FOR it := 1 TO errinx DO
1392 
1393           BEGIN
1394             errnumb := errlist [it].nmr ;
1395             IF NOT (errnumb MOD maxset IN erredited [errnumb DIV maxset]) THEN
1396               BEGIN
1397                 prterrmeans (mpcogerr, errnumb) ; writeln (mpcogerr) ;
1398                 erredited [errnumb DIV maxset] := erredited [errnumb DIV maxset] +
1399                 [errnumb MOD maxset] ;
1400               END
1401           END ;
1402         writeln (mpcogerr) ;
1403         errinx := 0 ;
1404         pos1 := 0 ;
1405       END (* PRINTERR *) ;
1406 
1407 
1408 $OPTIONS page $
1409 
1410 (* ***********************************************NEXTCH*********************** *)
1411 
1412     PROCEDURE nextch ;
1413 
1414 (* C .GIVES TO INSYMBOL THE NEXT RELEVANT  CHARACTER OF SOURCE.
1415    .AT EOLN   PRINTS  LAST LINE
1416    .AT EOF    EXITS COMPIL.
1417    C *)
1418 (* E  ERRORS DETECTED
1419    18: ' EXPECTED
1420    22: EOF ON FILE INPUT =SOURCE
1421    257: SOURCE LINE  IS TOO LONG
1422    E *)
1423       LABEL
1424         1, 2 ;                                    (*  EXIT OF LOOP FOR CH#' '  *)
1425       VAR
1426         caract : char ;
1427         it, startit, chprint, index, ll : integer ;
1428         listingline : PACKED ARRAY [1..maxsliceline] OF char ;
1429         ch1 : char ;
1430         liststatus : boolean ;
1431       BEGIN                                       (* NEXTCH *)
1432 2 :
1433         IF beginline THEN BEGIN
1434             beginline := false ;
1435             IF incomment OR skipcode THEN sourcectx := '*' ELSE sourcectx := ' '
1436           END ;
1437         IF eoln (mpcogin) THEN                    (* END OF CURRENT LINE *)
1438           IF NOT eof (mpcogin) THEN
1439             BEGIN
1440               IF listyes OR (errinx > 0) THEN     (* L+ OR ERROR(S) ON LINE *)
1441                 BEGIN                             (* PRINTS THIS LINE *)
1442                   liststatus := listyes ; listyes := true ;
1443                   IF instring AND (envstandard <> stdextend) THEN
1444                     BEGIN error (18) ; instring := false ; END ;
1445                                                   (* PRINTS FILE NO, LINE NO *)
1446                   IF filetoprint = 0 THEN ll := swrite (listingline, 1, '    ', linetoprint : 5, sourcectx)
1447                   ELSE ll := swrite (listingline, 1, filetoprint : 3, ' ', linetoprint : 5, sourcectx) ;
1448                                                   (* NOW PRINTS SOURCE . *)
1449                                                   (* 'LGPRINT' CHARS ON A LINE, *)
1450                                                   (* SEVERAL LINES ALLOWED *)
1451                   startit := 2 ; it := 1 ; chprint := 0 ;
1452                   WHILE it <= chcnt DO
1453                     BEGIN
1454                       caract := symbline [it] ;
1455                       IF caract = '     ' THEN    (* TAB *)
1456                         chprint := ((chprint + 10) DIV 10) * 10
1457                       ELSE
1458                         chprint := chprint + 1 ;
1459                       IF chprint >= lgprint THEN
1460                         BEGIN
1461                           ll := swrite (listingline, ll, symbline : 2 + it - startit : startit) ;
1462                           startit := it + 2 ;
1463                           write (mpcogout, listingline : ll - 1) ;
1464                           nextline ;
1465                           ll := swrite (listingline, 1, '   ') ;
1466                           chprint := 0 ;
1467                         END ;
1468                       it := it + 1 ;
1469                     END ;
1470                   IF chprint <> 0 THEN
1471                     ll := swrite (listingline, ll, symbline : 1 + it - startit : startit) ;
1472                   write (mpcogout, listingline : ll - 1) ;
1473                   nextline ;
1474                   IF errinx > 0 THEN printerr ;
1475                   listyes := liststatus ;
1476                 END (* LISTING *) ;
1477               bufold := bufnew ; bufnew := '   ' ;
1478               chcnt := -1 ;                       (* SYMBLINE[0] = SPACE  DUMMY *)
1479                                                   (* DUE TO EOLN *)
1480               beginline := true ;
1481               prevfile := filetoprint ;
1482               prevlig := linetoprint ;
1483               column := -1 ;
1484               liglues := liglues + 1 ;            (* LINES' COUNTER *)
1485                                                   (* AT BEGINNING OF NEXT PRINTED LINE *)
1486               err257 := false ;                   (* TO AVOID SEVERAL ERROR(257) *)
1487                                                   (* ON THE SAME LINE *)
1488               filetoprint := sourcenbr ;
1489               linetoprint := liglues ;
1490             END (* EOLN *) ;
1491         IF eof (mpcogin) THEN
1492           IF sourcenbr = 0 THEN
1493             BEGIN
1494               IF compencours THEN error (22) ;
1495               GOTO 100 ;                          (* GOTO    END OF COMPILER *)
1496             END
1497           ELSE
1498             BEGIN
1499               endsource ;                         (* END OF INCLUDE FILE *)
1500               GOTO 2 ;
1501             END ;
1502                                                   (* HERE VITAL PART *)
1503                                                   (* ==> ASSIGNS CH FOR INSYMBOL *)
1504         REPEAT
1505           ch1 := ch ;
1506           read (mpcogin, ch) ;                    (* SPACE RETURNED  IF EOLN(MPCOGIN)   *)
1507           sourceindex := sourceindex + 1 ;
1508           IF chcnt < maxlinepascal THEN
1509             BEGIN
1510               chcnt := chcnt + 1 ;
1511               symbline [chcnt] := ch ; IF chcnt < maxsliceline THEN bufnew [chcnt] := ch ;
1512               IF ch = '       ' THEN              (* TAB *)
1513                 BEGIN
1514                   IF column = -1 THEN column := 0 ;
1515                   column := ((column + 10) DIV 10) * 10
1516                 END
1517               ELSE column := column + 1 ;
1518             END ELSE
1519             IF NOT err257 THEN
1520               BEGIN error (257) ;
1521                 err257 := true ;
1522               END ;
1523           IF (ch # ' ') OR (ch1 # ' ') THEN GOTO 1 ; (* EXIT REPEAT *)
1524         UNTIL eoln (mpcogin) OR instring OR eof (mpcogin) ;
1525 1 :
1526         IF NOT instring THEN ch := chr (majmin [ord (ch)]) ;
1527       END (* NEXTCH *) ;
1528 
1529 
1530 $OPTIONS page $
1531 
1532 (* ***********************************************TRACELEVEL******************* *)
1533 
1534     PROCEDURE tracelevel (VAR whichtrace : levtrace ; charfound : char) ;
1535 
1536 (* C   A TRACE COMMAND  WAS FOUND;  THE  CHAR GIVING WANTED LEVEL ALSO.
1537    C *)
1538 (* E   ERRORS DETECTED
1539    25:  INVALID  TRACE  OPTIONS   IN  COMPILER  PARMLIST
1540    E *)
1541       BEGIN
1542         whichtrace := none ;                      (* DEFAULT *)
1543         IF charfound = '0' THEN whichtrace := none ELSE
1544           IF charfound = '1' THEN whichtrace := low ELSE
1545             IF charfound = '2' THEN whichtrace := medium ELSE
1546               IF charfound = '3' THEN whichtrace := high ELSE
1547                 error (25) ;
1548         anytrace := decltrace ;
1549         IF anytrace < stattrace THEN anytrace := stattrace ;
1550         IF anytrace < genetrace THEN anytrace := genetrace ;
1551       END (* TRACELEVEL *) ;
1552 
1553 
1554 $OPTIONS page $
1555 
1556     PROCEDURE traiteinclude ; FORWARD ;
1557     PROCEDURE traiteoptions ; FORWARD ;
1558 
1559 (* *******************************************************************INSYMBOL* *)
1560 
1561     PROCEDURE insymbol ;
1562 
1563 (* C  .ASSIGNS A CODE  (NO,CL)  TO EACH ITEM
1564    .RETURNS VALUE   IN  IVAL,RVAL,BUFVAL
1565    .SKIPS  COMMENT   AND  COMPIL. COND.
1566    .DECODE   OPTIONS
1567 
1568    INSYMBOL'S  OUTPUT   SUMMARY
1569 
1570    *NO*CL*****ITEM***SYNONYMS*******OUTPUTS*******||||**NO**CL***ITEM************
1571 
1572    .    1 LG       ID.                AVAL                     21        BEGIN
1573    .    2  1       CST. INT           IVAL                     22        END
1574    .       2          . REAL          RVAL                     23        IF
1575    .       3          . ALFA          BUFVAL  LONGCHAINE       24        THEN
1576    .       4          . CHAR          IVAL                     25        ELSE
1577    .                                                        26        CASE
1578    .    5  1       NOT                                         27        OF
1579    28        REPEAT
1580    .    6  1         *                                         29        UNTIL
1581    .       2         /                                         30        WHILE
1582    .       3       AND                                         31        DO
1583    .       4       DIV                                         32        FOR
1584    .       5       MOD                                         33 1      TO
1585    .                                                           2      DOWNTO
1586    .    7  1         +
1587    .       2         -                                         35        GOTO
1588    .       3        OR                                         36        NIL
1589    37        TYPE
1590    .    8  1        <                                          38 1      ARRAY
1591    .       2        <=                                            2      RECORD
1592    .       3        >=                                            3      FILE
1593    .       4        >                                             4      CLASS
1594    .       5        <>    #                                       5      SET
1595    .       6        =                                          39     ...SEE  CHAR..
1596    .       7        IN                                         40        LABEL
1597    .                                                        41        CONST
1598    .                                                        42        PACKED
1599    .    9           (                                          43        VAR
1600    .   10           )                                          44        FUNCTION
1601    .   11           [        (.                                45        PROCEDURE
1602    .   12           ]        .)                                46   .... CF SKIP ...
1603    .   55           $                                          47        VALUE
1604    .   56          $include
1605    .   15           ,                                          48        WITH
1606    .   16          ;                                           49     ...SEE CHAR..
1607    .   17           .                                          50        PROGRAM
1608    .   18           @               ^
1609    .   19           :
1610    .   20           :=
1611    .   39           ..
1612    .   49           ->
1613    C *)
1614 (* E
1615    32  OCTAL NUMBER IS NOT STANDARD
1616    33  HEXADECIMAL,BINARY NUMBER IS NOT STANDARD
1617    70 OBSOLETE CONDITIONNAL COMPILATION MECHANISM
1618    200  CHARACTER NOT ALLOWED IN PASCAL TEXT
1619    201  ERROR IN REAL CONSTANT DIGIT EXPECTED
1620    202  ERROR IN EXPONENT OF REAL CONSTANT
1621    203  INTEGER CONSTANT OUT OF RANGE
1622    204  ILLEGAL DIGIT IN OCTAL CONSTANT
1623    205  EXPONENT OUT OF RANGE
1624    206  DECIMAL CONSTANT IS TOO LONG
1625    207  OCTAL CONSTANT IS TOO LONG
1626    208  ILLEGAL NESTING OF ( /  AND  / )
1627    209  CHARACTERS' STRING IS TOO LONG
1628    210  HEXADECIMAL VALUE IS TOO LONG
1629    211  ILLEGAL DIGIT IN HEXADECIMAL CONSTANT
1630    212  ERROR IN COMPILATION'S  OPTIONS
1631    215 Too many digits
1632    216 Only 0 ou 1 allowed
1633    217 REAL > MAXREAL
1634    218 REAL < MINREAL
1635    219 TOO MANY PRECISION DIGITS FOR A REAL
1636    220 Empty string not allowed
1637    222
1638    223  Invalid number separator
1639    224 REFERENCE TO THIS IDENTIFIER IS NOT ALLOWED HERE.
1640    E *)
1641       LABEL 1,                                    (* BEGINNING OF INSYMBOL *)
1642         3,                                        (* EXIT WHEN KEY-WORD IS FOUND *)
1643         4,
1644         5 ;                                       (* COMMENT *)
1645       VAR
1646         it, k, scale, exp, valhex : integer ;
1647         sign, combraces, option, fin : boolean ;
1648         locvalue : integer ;
1649         locsomme : integer ;
1650         ch1 : char ;
1651         nbrstring : numberstring ;
1652 
1653       BEGIN                                       (* INSYMBOL *)
1654         IF building_from_schema.on THEN
1655           WITH building_from_schema DO
1656             BEGIN
1657               WITH current_token^ DO
1658                 CASE kind OF
1659                   symbol_token : BEGIN no := tno ; cl := tcl END ;
1660                   name_token : BEGIN aval := taval ; no := 1 END ;
1661                   int_const_token : BEGIN no := 2 ; cl := 1 ; ival := t_int_value END ;
1662                   real_const_token : BEGIN no := 2 ; cl := 2 ; rval := t_real_value END ;
1663                   char_const_token : BEGIN no := 2 ; cl := 4 ; ival := ord (t_char_value) END ;
1664                 END ;
1665               current_token := current_token^.next ;
1666               IF current_token = NIL THEN on := false ;
1667             END
1668         ELSE
1669           BEGIN
1670 1 :         IF dpoint THEN (* INTEGER.. AT LAST CALL *) (* .. *)
1671               BEGIN
1672                 dpoint := false ; no := 39 ;
1673                 nextch ;
1674               END ELSE
1675               BEGIN                               (* NOT DPOINT *)
1676 4 :
1677                 WHILE ch = ' ' DO nextch ;        (* CH IS CHECKED BY NEXTCH *)
1678                 symbolindex := sourceindex ;
1679                 symbolline := liglues ;
1680                 symbolfile := sourcenbr ;
1681                 IF ch IN ['a'..'z', '$'] THEN
1682                   BEGIN
1683                     IF ch = '$' THEN
1684                       IF envstandard = stdpure THEN
1685                         BEGIN
1686                           error (200) ;
1687                           nextch ;
1688                           IF NOT (ch IN ['a'..'z']) THEN GOTO 4
1689                         END ;
1690                     k := 0 ; aval := blank ;
1691                     IF envstandard <> stdextend THEN
1692                       REPEAT
1693                         IF k < maxident THEN
1694                           BEGIN
1695                             k := k + 1 ; aval [k] := ch ;
1696                           END ;
1697                         nextch ;
1698                       UNTIL NOT (ch IN ['a'..'z', '0'..'9'])
1699                     ELSE
1700                       REPEAT
1701                         IF k < maxident THEN
1702                           BEGIN
1703                             k := k + 1 ; aval [k] := ch ;
1704                           END ;
1705                         nextch ;
1706                       UNTIL NOT (ch IN ['a'..'z', '0'..'9', '_']) ; (* UNDERSCORE IS ALLOWED IN NO STANDARD *)
1707                                                   (* KEY-WORDS *)
1708                     IF k <= maxkeylength THEN
1709                       FOR it := wl1 [k] TO wl2 [k] DO (* KEY-WORD *)
1710                         IF aval = wd [it] THEN
1711                           BEGIN
1712                             no := wno [it] ; cl := wcl [it] ; GOTO 3 ; (* EXIT LOOP ,KEY-WORD FOUND *)
1713                           END ;
1714                     no := 1 ; cl := k ;
1715                     IF check_id THEN
1716                       IF aval = forbidden_id THEN error (224)
1717                       ELSE
1718                         BEGIN
1719                           IF forbidden_id_list^.next = NIL THEN
1720                             BEGIN
1721                               new (forbidden_id_list^.next) ;
1722                               WITH forbidden_id_list^.next^ DO
1723                                 BEGIN
1724                                   previous := forbidden_id_list ;
1725                                   next := NIL
1726                                 END
1727                             END ;
1728                           forbidden_id_list := forbidden_id_list^.next ;
1729                           forbidden_id_list^.name := aval ;
1730                         END ;
1731                                                   (* if aval[1] = '$' then error(200) ; *)
1732 3 :
1733                     IF no = 56 THEN               (* $include founded *)
1734                       BEGIN
1735                         traiteinclude ;
1736                         GOTO 1
1737                       END ;
1738                     IF no = 57 THEN
1739 
1740                       IF NOT skipcode THEN
1741                         BEGIN
1742                           traiteoptions ;
1743                           GOTO 1 ;
1744                         END ;
1745                   END (* letter *) ELSE
1746                   IF ch IN digits THEN
1747                     BEGIN                         (* NUMBER *)
1748                       no := 2 ; cl := 1 ;
1749                       it := 1 ; ival := 0 ; nbrstring := '+0000000000000000000' ;
1750                       WHILE ch = '0' DO nextch ;  (* SKIP LEADING ZEROES *)
1751                       WHILE ch IN digits DO
1752                         BEGIN
1753                           it := it + 1 ;
1754                           IF it <= maxdigitsinteger THEN
1755                             nbrstring [it] := ch ;
1756                           nextch
1757                         END ;
1758                       IF ch IN letters THEN
1759                         IF ch <> 'E' THEN
1760                           IF ch <> 'e' THEN
1761                             error (223) ;
1762                       IF (it > maxdigitsinteger) OR
1763                         ((it = maxdigitsinteger) AND (nbrstring > maxintegerstring))
1764                       THEN
1765                         BEGIN
1766                           error (203) ;
1767                           it := 1
1768                         END
1769                       ELSE
1770                         FOR k := 2 TO it DO
1771                           ival := (ival * 10) + (ord (nbrstring [k]) - ord ('0')) ;
1772                       exp := it - 1 ;
1773 
1774                       IF ch = '.' THEN
1775                         BEGIN
1776                           nextch ;
1777                           IF ch = '.' THEN dpoint := true ELSE
1778                             IF ch = ')' THEN ch := ']' ELSE
1779                               BEGIN
1780                                 rval := ival ; cl := 2 ; (* REAL *)
1781                                 IF NOT (ch IN digits) THEN error (201) ELSE
1782                                   BEGIN
1783                                     IF it = 1 THEN
1784                                       WHILE ch = '0' DO
1785                                         BEGIN
1786                                           exp := exp - 1 ;
1787                                           nextch
1788                                         END ;
1789                                     WHILE ch IN digits DO
1790                                       BEGIN
1791                                         it := it + 1 ;
1792                                         IF it <= maxdigitsreal THEN nbrstring [it] := ch ;
1793                                         nextch
1794                                       END ;
1795                                     IF it > maxdigitsreal THEN warning (219)
1796                                   END
1797                               END
1798                         END (* ch = '.' *) ;
1799 
1800                       IF ch = 'e' THEN
1801                         BEGIN
1802                           nextch ;
1803                           rval := ival ; cl := 2 ; scale := exp ; exp := 0 ; (* REAL *)
1804                           sign := false ;
1805                           IF ch = '+' THEN nextch
1806                           ELSE
1807                             IF ch = '-' THEN
1808                               BEGIN
1809                                 nextch ; sign := true ;
1810                               END ;
1811                           IF NOT (ch IN digits) THEN error (201)
1812                           ELSE
1813                             REPEAT
1814                               IF exp < maxexpon THEN
1815                                 exp := (exp * 10) + (ord (ch) - ord ('0')) ;
1816                               nextch
1817                             UNTIL NOT (ch IN digits) ;
1818                           IF sign THEN exp := scale - exp
1819                           ELSE exp := scale + exp ;
1820                         END (* CH = 'E' *) ;
1821 
1822                       IF cl = 2 THEN              (* CHECK BOUNDS AND CONVERT REAL *)
1823                         IF it = 1 THEN rval := 0  (* MANTISSA IS ZERO *)
1824                         ELSE
1825                           IF (exp > maxexp)
1826                             OR ((exp = maxexp) AND (nbrstring > maxrealstring)) THEN error (217)
1827                           ELSE
1828                             IF (exp < minexp)
1829                               OR ((exp = minexp) AND (nbrstring < minrealstring)) THEN error (218)
1830                             ELSE
1831                               BEGIN
1832                                 exp := exp - 19 ;
1833                                 convertreal (nbrstring, exp, rval)
1834                               END ;
1835 
1836                     END (* CH IN DIGITS *) ELSE
1837                     BEGIN                         (* SPECIAL CHARACTER *)
1838                       IF ch = '''' THEN           (* ALFA  OR CHAR *)
1839                         BEGIN
1840                           no := 2 ; longchaine := 0 ; instring := true ;
1841                           REPEAT
1842                             IF eoln (mpcogin) THEN
1843                               BEGIN
1844                                 IF envstandard <> stdextend THEN error (231) ;
1845                                 nextch ; ch := chr (10) ; (* ASCII NEW-LINE *)
1846                               END ELSE
1847                               nextch ;
1848                             IF ch = '''' THEN     (* ' *)
1849                               BEGIN
1850                                 instring := false ; (* TO OBTAIN  A PASCAL CHAR *)
1851                                 nextch ;
1852                                 instring := ch = '''' ;
1853                               END ELSE
1854                               IF ch = chr (92) THEN
1855                                 IF envstandard = stdsol THEN
1856                                   BEGIN
1857                                     nextch ;
1858                                     IF ch IN ['N', 'n', 'Z', 'z', 'T', 't', 'R', 'r', 'V', 'A'..'F', 'a'..'f',
1859                                       '0'..'9'] THEN
1860                                       BEGIN
1861                                         CASE ch OF
1862                                           'N', 'n' : ch := chr (10) ; (* ASCII NEWLINE *)
1863                                           'Z', 'z' : ch := chr (0) ;
1864                                           'T', 't' : ch := chr (9) ; (* HORIZONTAL TABULATION *)
1865                                           'R', 'r' : ch := chr (13) ; (* CARRIAGE RETURN *)
1866                                           'V' : ch := chr (92) ; (* ASCII ANTISLASH *)
1867                                           '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
1868                                           'A', 'B', 'C', 'D', 'E', 'F',
1869                                           'a', 'b', 'c', 'd', 'e', 'f' : BEGIN (* HEXADECIMAL DIGIT *)
1870                                               locvalue := 0 ;
1871                                               IF ch IN ['0'..'9'] THEN
1872                                                 locvalue := ord (ch) - ord ('0') ELSE
1873                                                 IF ch IN ['A'..'F'] THEN
1874                                                   locvalue := ord (ch) - ord ('A') + 10 ELSE
1875                                                   locvalue := ord (ch) - ord ('a') + 10 ;
1876                                               locsomme := locvalue * 16 ; (* FIRST DIGIT HEXA *)
1877                                               nextch ;
1878                                               IF ch IN ['0'..'9'] THEN
1879                                                 locvalue := ord (ch) - ord ('0') ELSE
1880                                                 IF ch IN ['A'..'F'] THEN
1881                                                   locvalue := ord (ch) - ord ('A') + 10 ELSE
1882                                                   locvalue := ord (ch) - ord ('a') + 10 ;
1883                                               locsomme := locsomme + locvalue ;
1884 
1885                                               IF locsomme <= maxchar THEN
1886                                                 ch := chr (locsomme) ELSE
1887                                                 error (303) ;
1888 
1889                                             END (* HEXADECIMAL DIGIT *) ;
1890                                         END (* case CH *) ;
1891                                       END ;
1892                                   END (* chr (92 *) ;
1893                             IF instring THEN
1894                               BEGIN
1895                                 longchaine := longchaine + 1 ;
1896                                 IF longchaine <= maxval THEN bufval [longchaine] := ch ;
1897                               END ;
1898                           UNTIL NOT instring ;
1899                           IF envstandard <> stdextend THEN
1900                             IF longchaine = 0 THEN
1901                               error (220) ;
1902                           IF ch = 'x' THEN (* HEXA *) (* HEXADECIMAL *)
1903                             BEGIN
1904                               IF envstandard = stdpure THEN
1905                                 error (33) ;
1906                               nextch ;
1907                               cl := 1 ;           (* CODE FOR INTEGER *)
1908                               ival := 0 ;
1909                               IF longchaine > maxhexdi THEN error (210) ELSE
1910                                 FOR it := 1 TO longchaine DO
1911                                   BEGIN
1912                                     IF bufval [it] IN digits
1913                                     THEN valhex := ord (bufval [it]) - ord ('0')
1914                                     ELSE
1915 
1916                                       IF bufval [it] IN ['A'..'F'] THEN
1917                                         valhex := ord (bufval [it]) - ord ('A') + 10 ELSE
1918                                         IF bufval [it] IN ['a'..'f'] THEN
1919                                           valhex := ord (bufval [it]) - ord ('a') + 10 ELSE
1920                                           BEGIN
1921                                             error (211) ; valhex := 0 ;
1922                                           END ;
1923                                     append_ (ival, 4, valhex) ;
1924                                   END ;
1925                             END (* HEXA *) ELSE
1926 
1927                             IF ch = 'o' THEN      (* octal number *)
1928                               BEGIN
1929                                 IF envstandard = stdpure THEN
1930                                   error (32) ;
1931                                 nextch ; cl := 1 ; (* integer *) ival := 0 ; no := 2 ;
1932                                 IF longchaine > maxdig + 1 THEN error (207) ELSE
1933                                   FOR it := 1 TO longchaine DO
1934                                     BEGIN
1935                                       valhex := ord (bufval [it]) - ord ('0') ;
1936                                       IF NOT (valhex IN [0..7]) THEN
1937                                         BEGIN error (204) ; valhex := 0 ;
1938                                         END ;
1939                                       append_ (ival, 3, valhex) ;
1940                                     END (* for it *) ;
1941                               END (* octal number *) ELSE
1942                               IF ch = 'b' THEN    (* binary *)
1943                                 BEGIN
1944                                   nextch ; cl := 1 ; (* integer *) ; ival := 0 ; no := 2 ;
1945                                   IF envstandard = stdpure THEN
1946                                     error (33) ;
1947                                   IF longchaine > bitsinword THEN error (215) ELSE
1948                                     FOR it := 1 TO longchaine DO
1949                                       BEGIN
1950                                         valhex := ord (bufval [it]) - ord ('0') ;
1951                                         IF NOT (valhex IN [0..1]) THEN
1952                                           BEGIN error (216) ; valhex := 0 ;
1953                                           END ;
1954                                         append_ (ival, 1, valhex) ;
1955                                       END ;       (* FOR IT *)
1956                                 END ELSE
1957                                 IF longchaine = 1 THEN (* CHAR *) (* CHAR *)
1958                                   BEGIN
1959                                     cl := 4 ; ival := ord (bufval [1]) ;
1960                                   END (* CHAR *) ELSE (* STRING *)
1961                                   BEGIN           (* ALFA *)
1962                                     cl := 3 ;
1963                                     IF longchaine > maxval THEN
1964                                       BEGIN
1965                                         error (209) ; longchaine := maxval ;
1966                                       END ;
1967                                   END ;           (* ALFA *)
1968                           IF longchaine >= longpad THEN longpad := longchaine ELSE
1969                             REPEAT                (* PADDING WITH SPACES *)
1970                               bufval [longpad] := ' ' ; longpad := longpad - 1 ;
1971                             UNTIL longpad = longchaine ;
1972                         END (* ALFA OR CHAR *) ELSE
1973                         BEGIN                     (* OTHER CHARS *)
1974                           no := symno [ord (ch)] ; (* SINGLE CHAR *)
1975                           cl := symcl [ord (ch)] ;
1976                           ival := 0 ;
1977                           IF NOT (eof (mpcogin) AND (sourcenbr = 0)) THEN
1978                             BEGIN
1979                               ch1 := ch ;
1980                               nextch ;
1981                                                   (* TEST FOR DOUBLE CHARS *)
1982                               IF ch1 = ':' THEN
1983                                 BEGIN
1984                                   IF ch = '=' THEN (* := *)
1985                                     BEGIN
1986                                       no := 20 ; nextch ;
1987                                     END ;
1988                                 END ELSE
1989                                 IF ch1 = '.' THEN
1990                                   BEGIN
1991                                     IF ch = '.' THEN (* .. *)
1992                                       BEGIN
1993                                         no := 39 ; nextch ;
1994                                       END ELSE
1995                                       IF ch = ')' THEN (* .) *)
1996                                         BEGIN
1997                                           no := 12 ; nextch ;
1998                                         END ;
1999                                   END ELSE
2000                                   IF ch1 = '-' THEN
2001                                     BEGIN
2002                                       IF envstandard = stdextend THEN
2003                                         IF ch = '>' THEN (* CRISS EXTENSION *)
2004                                           BEGIN
2005                                             no := 49 ; cl := 0 ; nextch ;
2006                                           END ;
2007                                     END ELSE
2008                                     IF ch1 = '<' THEN
2009                                       BEGIN
2010                                         IF ch = '=' THEN (* <= *)
2011                                           BEGIN   (* NO=8 *)
2012                                             cl := 2 ; nextch ;
2013                                           END ELSE
2014                                           IF ch = '>' THEN (* <> *)
2015                                             BEGIN
2016                                               cl := 5 ; nextch ;
2017                                             END ;
2018                                       END ELSE
2019                                       IF ch1 = '>' THEN
2020                                         BEGIN
2021                                           IF ch = '=' THEN (* >= *)
2022                                             BEGIN (* NO=8 *)
2023                                               cl := 3 ; nextch ;
2024                                             END ;
2025                                         END ELSE
2026                                         IF ch1 = '/' THEN
2027                                           BEGIN
2028                                             IF (ch = ')') THEN (* NS *) (* / ) *)
2029                                               BEGIN
2030                                                 error (70) ;
2031                                                 nextch ;
2032                                                 GOTO 1 ; (* FOLLOWING MECHANISM IS OBSOLETE AND SKIPPED *)
2033                                                 IF envstandard <> stdextend THEN error (70) ;
2034                                                 nextch ;
2035                                                 IF nbccond = 0 THEN error (208)
2036                                                 ELSE nbccond := nbccond - 1 ;
2037                                                 GOTO 1 ; (* BEGINNING OF INSYMBOL *)
2038                                               END ;
2039                                           END ELSE
2040                                           IF ch1 = '(' THEN
2041                                             BEGIN
2042                                               IF ch = '.' THEN
2043                                                 BEGIN (* (. *)
2044                                                   no := 11 ; nextch ;
2045                                                 END ELSE
2046                                                 IF ch = '*' THEN
2047                                                   BEGIN (* (* *)
2048                                                     nextch ;
2049                                                     combraces := false ;
2050                                                     incomment := true ;
2051                                                   END ;
2052                                             END ELSE
2053                                             IF ch1 = '{' THEN (* COMMENT WITH BRACE *)
2054                                               BEGIN
2055                                                 combraces := true ;
2056                                                   (* NEXTCH HAS BEEN DONE *)
2057 5 :                                             incomment := true ;
2058                                               END ; (* COMMENT *)
2059                             END ;                 (* OTHER CHARS *)
2060                         END                       (* NOT EOF(MPCOGIN) *)
2061                     END ;                         (* SPECIAL CHARS *)
2062               END ;                               (* NOT DPOINT *)
2063 
2064             IF incomment THEN
2065               BEGIN
2066                 IF envstandard = stdpure THEN
2067                   REPEAT
2068                     WHILE NOT (ch IN ['}', '*']) DO nextch ;
2069                     fin := ch = '}' ;
2070                     IF NOT fin THEN
2071                       BEGIN
2072                         nextch ; fin := ch = ')'
2073                       END
2074                   UNTIL fin
2075                 ELSE
2076                   IF combraces THEN               (* COMMENT WITH BRACES *)
2077                     WHILE ch <> '}' DO nextch
2078                   ELSE
2079                     REPEAT
2080                       WHILE ch <> '*' DO nextch ;
2081                       nextch ; fin := ch = ')' ;
2082                     UNTIL fin ;
2083                 incomment := false ;
2084                 nextch ;
2085                 GOTO 1 ;                          (* RESTART INSYMBOL *)
2086               END ;
2087           END ;
2088 
2089 $OPTIONS compile = trace $
2090         IF anytrace > low THEN
2091           BEGIN
2092             write (mpcogout, ' @@@ RETOUR INSYMBOL @@@ WITH NO,CL', no : 4, cl : 4) ; nextline ;
2093           END ;
2094 $OPTIONS compile = true $
2095       END (* INSYMBOL *) ;
2096 
2097 
2098 $OPTIONS page $
2099 
2100     PROCEDURE skip (nosymb : integer) ; FORWARD ;
2101     PROCEDURE skipextd (nosymb : setofno) ; FORWARD ;
2102 
2103 (* *************************************************** TRAITEINCLUDE ******************** *)
2104 
2105     PROCEDURE traiteinclude ;
2106 
2107 (* c CALLED BY INSYMBOL WHEN $INCLUDE DIRECTIVE HAS BEEN ENCOUNTERED      C *)
2108 
2109 (* E
2110    35 : MAX LENGTH FOR EXTERNAL IS 168 CHARS
2111    38 : ',' OR '$' EXPECTED
2112    39 : STRING OR '*' EXPECTED
2113    40 : '$' EXPECTED
2114    41 : THIS STRING CANNOT BE > 32 CHARS                                        E *)
2115 
2116       LABEL
2117         10 ;                                      (* EXIT ON ERROR *)
2118 
2119       VAR
2120         filename : externid ;                     (* NAME OF INCLUDE FILE *)
2121         stringdeb, stringfin : alfaid ;           (* OPTIONAL BEGIN AND END STRINGS *)
2122         it, ldeb, lfin : integer ;
2123 
2124       BEGIN                                       (* TRAITEINCLUDE *)
2125 $OPTIONS compile = trace $
2126         IF anytrace > low THEN
2127           BEGIN
2128             write (mpcogout, ' @@@ DEBUT TRAITEINCLUDE @@@') ; nextline ;
2129           END ;
2130 $OPTIONS compile = true $
2131         insymbol ;                                (* FILENAME STRING *)
2132         IF NOT ((no = 2) AND (cl = 3)) THEN
2133           BEGIN
2134             error (19) ;
2135             skip (55) ;
2136             GOTO 10
2137           END ;
2138         IF longchaine > maxexternname THEN
2139           BEGIN
2140             error (35) ;
2141             longchaine := maxexternname
2142           END ;
2143         filename := '  ' ;
2144         FOR it := 1 TO longchaine DO
2145           filename [it] := bufval [it] ;
2146         stringdeb := '  ' ;
2147         stringfin := '  ' ;
2148                                                   (* CHECK FOR OPTIONNAL STRINGS *)
2149         WHILE ch = ' ' DO nextch ;
2150         IF ch = '$' THEN
2151           BEGIN
2152             stringdeb := '* ' ; ldeb := 1 ;
2153             stringfin := '* ' ; lfin := 1
2154           END
2155         ELSE
2156           BEGIN
2157             insymbol ;
2158             IF no <> 15 THEN
2159               BEGIN
2160                 error (38) ;
2161                 skip (55) ;
2162                 GOTO 10
2163               END ;
2164             insymbol ;                            (* '*' OR STRING EXPECTED *)
2165             IF (no = 6) AND (cl = 1) THEN         (* '*' *)
2166               BEGIN
2167                 stringdeb := '* ' ;
2168                 ldeb := 1
2169               END
2170             ELSE
2171               BEGIN
2172                 IF NOT ((no = 2) AND (cl = 3)) THEN
2173                   BEGIN
2174                     error (39) ;
2175                     skip (55) ;
2176                     GOTO 10
2177                   END ;
2178                 IF longchaine > maxident THEN
2179                   BEGIN
2180                     error (41) ;
2181                     longchaine := maxident
2182                   END ;
2183                 FOR it := 1 TO longchaine DO
2184                   stringdeb [it] := bufval [it] ;
2185                 ldeb := longchaine ;
2186               END ;
2187             WHILE ch = ' ' DO nextch ;
2188             IF ch = '$' THEN
2189               BEGIN
2190                 stringfin := '* ' ;
2191                 lfin := 1
2192               END
2193             ELSE
2194               BEGIN
2195                 insymbol ;
2196                 IF no <> 15 THEN
2197                   BEGIN
2198                     error (38) ;
2199                     skip (55) ;
2200                     GOTO 10
2201                   END ;
2202                 insymbol ;                        (* '*' OR STRING EXPECTED *)
2203                 IF (no = 6) AND (cl = 1) THEN     (* '*' *)
2204                   BEGIN
2205                     stringfin := '* ' ;
2206                     lfin := 1
2207                   END
2208                 ELSE
2209                   BEGIN
2210                     IF NOT ((no = 2) AND (cl = 3)) THEN
2211                       BEGIN
2212                         error (39) ;
2213                         skip (55) ;
2214                         GOTO 10
2215                       END ;
2216                     IF longchaine > maxident THEN
2217                       BEGIN
2218                         error (41) ;
2219                         longchaine := maxident
2220                       END ;
2221                     FOR it := 1 TO longchaine DO
2222                       stringfin [it] := bufval [it] ;
2223                     lfin := longchaine ;
2224                   END ;
2225                 WHILE ch = ' ' DO nextch ;
2226                 IF ch <> '$' THEN
2227                   BEGIN
2228                     error (40) ;
2229                     skip (55) ;
2230                     GOTO 10
2231                   END
2232               END
2233           END ;
2234         beginsource (filename, stringdeb, ldeb, stringfin, lfin) ; (* BEGIN INCLUDE FILE *)
2235         reset (mpcogin) ;
2236         nextch ;
2237 10 :
2238 $OPTIONS compile = trace $
2239         IF anytrace > low THEN
2240           BEGIN
2241             write (mpcogout, ' @@@ FIN TRAITEINCLUDE @@@') ; nextline ;
2242           END ;
2243 $OPTIONS compile = true $
2244       END (* TRAITEINCLUDE *) ;
2245 
2246 
2247 $OPTIONS page $
2248 
2249 (* ***************************************** TRAITEOPTIONS ************************************** *)
2250 
2251     PROCEDURE traiteoptions ;
2252 
2253 (* C CALLED BY INSYMBOL WHEN "$OPTIONS" DIRECTIVE IS ENCOUNTERED       C *)
2254 
2255 (* E ERRORS DETECTED ARE :
2256 
2257    47 : OPTION IDENTIFIER EXPECTED
2258    16 : "=" EXPECTED
2259    50 : "$" OR ";" EXPECTED
2260    49 : "+" OR "-" EXPECTED
2261    34 : CONDITION IDENTIFIER EXPECTED
2262    35 : "," OR ";" OR "$" EXPECTED
2263    48 : UNKNOWN OPTION
2264    15 : INTEGER EXPECTED
2265 
2266    E *)
2267 
2268       LABEL
2269         1, 3, 4, 5, 10 ;
2270 
2271       VAR
2272         ch : char ;
2273         flag : boolean ;
2274         work : condaddr ;
2275 
2276 (* ************************************************* SKIPOPTION < TRAITEOPTIONS ************************* *)
2277 
2278       PROCEDURE skipoption (errno : integer) ;
2279 
2280         BEGIN                                     (* SKIPOPTION *)
2281           error (errno) ;
2282           IF no = 55 THEN GOTO 10 ;
2283           IF no = 16 THEN GOTO 1 ;
2284           skipextd ([16, 55]) ;
2285           IF no = 55 THEN GOTO 10
2286           ELSE GOTO 1 ;
2287         END (* SKIPOPTION *) ;
2288 
2289 (* ************************************************ CHECKPLUSMINUS < TRAITEOPTIONS ********************** *)
2290 
2291       FUNCTION checkplusminus : boolean ;
2292 
2293         BEGIN                                     (* CHECKPLUSMINUS *)
2294           insymbol ;
2295           checkplusminus := false ;
2296           IF (no = 7) AND (cl = 1) THEN checkplusminus := true
2297           ELSE IF NOT ((no = 7) AND (cl = 2)) THEN skipoption (49) ;
2298         END (* CHECKPLUSMINUS *) ;
2299 
2300 (* ******************************************* FINDCOND < TRAITEOPTIONS ******************** *)
2301 
2302       PROCEDURE findcond ;
2303 
2304         LABEL 5 ;
2305 
2306         BEGIN
2307           work := firstcond ;
2308 5 :
2309           IF work <> NIL THEN
2310             IF work^.condname <> aval THEN
2311               BEGIN
2312                 work := work^.nextcond ;
2313                 GOTO 5 ;
2314               END ;
2315         END ;                                     (* findcond *)
2316 
2317 (* ****************************** CHECKVALUE < TRAITEOPTIONS ******************* *)
2318 
2319       FUNCTION checkvalue : boolean ;
2320 
2321         VAR
2322           invert : boolean ;
2323         BEGIN
2324           insymbol ;
2325           IF no <> 1 THEN
2326             IF NOT ((no = 5) AND (cl = 1)) THEN skipoption (314)
2327             ELSE
2328               BEGIN
2329                 invert := true ;
2330                 insymbol ;
2331                 IF no <> 1 THEN skipoption (316)
2332               END
2333           ELSE invert := false ;
2334           IF aval = 'true' THEN checkvalue := true
2335           ELSE IF aval = 'false' THEN checkvalue := false
2336             ELSE BEGIN
2337                 findcond ;
2338                 IF work = NIL THEN skipoption (315) ;
2339                 checkvalue := work^.active ;
2340               END ;
2341           IF invert THEN checkvalue := NOT checkvalue ;
2342         END (* CHECKVALUE *) ;
2343 
2344 (* ******************************* CREATECOND < TRAITEOPTIONS ***************************** *)
2345 
2346       PROCEDURE createcond ;
2347 
2348         BEGIN
2349           new (work) ;
2350           IF work = NIL THEN heaperror ;
2351           WITH work^ DO
2352             BEGIN
2353               nextcond := firstcond ;
2354               condname := aval ;
2355               setinargs := false ;
2356               active := false ;
2357               activated := false ;
2358             END ;
2359           firstcond := work ;
2360 
2361         END (* CREATECOND *) ;
2362 
2363       BEGIN                                       (* TRAITEOPTION *)
2364 
2365 $OPTIONS compile = trace $
2366         IF anytrace > low THEN
2367           BEGIN
2368             write (mpcogout, ' @@@ DEBUT TRAITEOPTIONS @@@') ; nextline ;
2369           END ;
2370 $OPTIONS compile = true $
2371 
2372 1 :
2373         insymbol ;
2374         IF no <> 1 THEN skipoption (47) ;
2375         ch := aval [1] ;
2376         IF NOT (ch IN ['w', 'l', 't', 'e', 'c', 'p', 'd', 's']) THEN skipoption (48) ;
2377         CASE ch OF
2378           'w' : BEGIN
2379               IF cl <> 3 THEN skipoption (48) ;
2380               IF NOT (aval [2] IN ['d', 's', 'g']) THEN skipoption (48) ;
2381               IF NOT (aval [3] IN ['0'..'3']) THEN skipoption (48) ;
2382               CASE aval [2] OF
2383                 'd' : IF (NOT wdsetinargs) THEN tracelevel (decltrace, aval [3]) ;
2384                 's' : IF (NOT wssetinargs) THEN tracelevel (stattrace, aval [3]) ;
2385                 'g' : IF (NOT wgsetinargs) THEN BEGIN
2386                       tracelevel (genetrace, aval [3]) ;
2387                       outcode := writecode OR (genetrace > none) ;
2388                     END ;
2389               END (* CASE *) ;
2390               insymbol ;
2391             END ;
2392           'l' : IF aval = 'l ' THEN
2393               BEGIN
2394                 flag := checkplusminus ;
2395                 IF NOT skipcode THEN
2396                   BEGIN
2397                     listyes := flag ;
2398                     writecode := writecode AND listyes ;
2399                     outcode := writecode OR (genetrace > none) ;
2400                   END ;
2401                 insymbol ;
2402               END
2403             ELSE
2404               IF aval = 'll' THEN
2405                 BEGIN
2406                   insymbol ;
2407                   IF NOT ((no = 8) AND (cl = 6)) THEN skipoption (16) ;
2408                   insymbol ;
2409                   IF NOT ((no = 2) AND (cl = 1)) THEN skipoption (15) ;
2410                                                   (* WARNING : LL INEFFECTIVE *)
2411                   warning (222) ;
2412                   insymbol ;
2413                 END
2414               ELSE IF aval = 'listing' THEN
2415                   BEGIN
2416                     insymbol ;
2417                     IF NOT ((no = 8) AND (cl = 6)) THEN skipoption (16) ;
2418                     listyes := checkvalue ;
2419                     writecode := writecode AND listyes ;
2420                     outcode := writecode OR (genetrace > none) ;
2421                     insymbol
2422                   END
2423                 ELSE skipoption (48) ;
2424           't' : IF aval = 't ' THEN
2425               BEGIN
2426                 flag := checkplusminus ;
2427                 IF (NOT skipcode) AND (NOT tsetinargs) THEN
2428                   BEGIN
2429                     divcheck := flag ;
2430                     asscheck := divcheck ;
2431                     inxcheck := divcheck ;
2432                   END ;
2433                 insymbol ;
2434               END
2435             ELSE skipoption (48) ;
2436           'p' : IF aval = 'page' THEN
2437               BEGIN
2438                 IF NOT skipcode THEN skippage := true ;
2439                 insymbol ;
2440               END
2441             ELSE IF aval = 'p ' THEN
2442                 BEGIN
2443                   flag := checkplusminus ;
2444                                                   (* WARNING : P INEFFECTIVE *)
2445                   warning (222) ;
2446                   insymbol ;
2447                 END
2448               ELSE skipoption (48) ;
2449           'e' : IF aval = 'ec' THEN
2450               BEGIN
2451                 flag := checkplusminus ;
2452                                                   (* WARNING : EC INEFFECTIVE *)
2453                 warning (222) ;
2454                 insymbol ;
2455               END
2456             ELSE skipoption (48) ;
2457           'c' : IF aval = 'cond' THEN
2458               BEGIN
2459                 insymbol ;
2460                 IF NOT ((no = 8) AND (cl = 6)) THEN skipoption (16) ;
2461 3 :
2462                 insymbol ;
2463                 IF no <> 1 THEN
2464                   IF NOT (no IN wnoset) THEN skipoption (34)
2465                   ELSE
2466                     IF ((no = 6) AND (NOT (cl IN [3, 4, 5])))
2467                       OR ((no = 7) AND (cl <> 3))
2468                       OR ((no = 8) AND (cl <> 7)) THEN skipoption (34) ;
2469                 findcond ;
2470                 IF work = NIL THEN
2471                   createcond ;
2472                 flag := checkplusminus ;
2473                 WITH work^ DO
2474                   IF NOT setinargs THEN active := flag ;
2475                 insymbol ;
2476                 IF NOT (no IN [15, 16, 55]) THEN skipoption (35) ;
2477                 IF no = 15 THEN GOTO 3 ;
2478               END
2479             ELSE IF aval = 'cc' THEN
2480                 BEGIN
2481                   insymbol ;
2482                   IF NOT ((no = 8) AND (cl = 6)) THEN skipoption (16) ;
2483 4 :
2484                   insymbol ;
2485                   IF no <> 1 THEN
2486                     IF NOT (no IN wnoset) THEN skipoption (34)
2487                     ELSE
2488                       IF ((no = 6) AND (NOT (cl IN [3, 4, 5])))
2489                         OR ((no = 7) AND (cl <> 3))
2490                         OR ((no = 8) AND (cl <> 7)) THEN skipoption (34) ;
2491                   findcond ;
2492                   IF work = NIL THEN
2493                     createcond ;
2494                   work^.activated := checkplusminus ;
2495                   insymbol ;
2496                   IF NOT (no IN [15, 16, 55]) THEN skipoption (35) ;
2497                   IF no = 15 THEN GOTO 4 ;
2498                   work := firstcond ;
2499                   skipcode := false ;
2500                   WHILE work <> NIL DO
2501                     BEGIN
2502                       skipcode := skipcode OR ((NOT work^.active) AND work^.activated) ;
2503                       work := work^.nextcond ;
2504                     END ;
2505                 END
2506               ELSE IF aval = 'compile' THEN
2507                   BEGIN
2508                     insymbol ;
2509                     IF NOT ((no = 8) AND (cl = 6)) THEN skipoption (16) ;
2510                     skipcode := NOT checkvalue ;
2511                     insymbol ;
2512                   END
2513                 ELSE skipoption (48) ;
2514           's' : IF aval = 'switch' THEN
2515               BEGIN
2516 5 :
2517                 insymbol ;
2518                 IF no <> 1 THEN skipoption (316) ;
2519                 findcond ;
2520                 IF work = NIL THEN createcond ;
2521                 insymbol ;
2522                 IF no = 20 THEN                   (* := *)
2523                   BEGIN
2524                     flag := checkvalue ;
2525                     insymbol ;
2526                   END
2527                 ELSE flag := false ;              (* default *)
2528                 WITH work^ DO
2529                   IF NOT setinargs THEN active := flag ;
2530                 IF NOT (no IN [15, 16, 55]) THEN skipoption (36) ;
2531                 IF no = 15 THEN GOTO 5 ;
2532               END
2533             ELSE skipoption (48) ;
2534           'd' : IF aval = 'debug' THEN
2535               BEGIN
2536                 insymbol ;                        (* = *)
2537                 IF NOT ((no = 8) AND (cl = 6)) THEN skipoption (16) ;
2538                 flag := checkvalue ;
2539                 IF (NOT tsetinargs) THEN
2540                   BEGIN
2541                     divcheck := flag ;
2542                     asscheck := divcheck ;
2543                     inxcheck := divcheck ;
2544                   END ;
2545 
2546                 insymbol ;
2547               END
2548             ELSE skipoption (48) ;
2549         END (* CASE *) ;
2550         IF no = 16 THEN GOTO 1 ;
2551         IF no <> 55 THEN skipoption (50) ;
2552 10 :
2553         IF skipcode THEN
2554           BEGIN
2555             REPEAT
2556               insymbol ;
2557             UNTIL (no = 57) ;
2558             GOTO 1 ;
2559           END ;
2560 
2561 $OPTIONS compile = trace $
2562         IF anytrace > low THEN
2563           BEGIN
2564             write (mpcogout, ' @@@ FIN TRAITEOPTIONS @@@') ; nextline ;
2565           END ;
2566 $OPTIONS compile = true $
2567 
2568       END (* TRAITEOPTION *) ;
2569 
2570 
2571 $OPTIONS page $
2572 
2573 (* **************************** STATEMENT BEGINS **************************** *)
2574 
2575     PROCEDURE statement_begins (genp : boolean) ;
2576 
2577       BEGIN
2578         IF ic <> startic THEN
2579           BEGIN
2580             sttplace := ic ;
2581             IF genp THEN
2582               IF profile THEN genprofileref
2583               ELSE IF longprofile THEN genlongprofileref ;
2584           END ;
2585         sttindex := symbolindex ;
2586         sttline := symbolline ;
2587         sttfile := symbolfile ;
2588         startic := ic ;
2589         end_statement := false ;
2590       END (* STATEMENT BEGINS *) ;
2591 
2592 $OPTIONS page $
2593 
2594 (* ****************************** STATEMENT ENDS **************************** *)
2595 
2596     PROCEDURE statement_ends (sttlength : integer) ;
2597 
2598       VAR
2599         locic : integer ;
2600 
2601       BEGIN
2602         IF NOT end_statement THEN
2603           IF ic <> startic THEN
2604             BEGIN
2605               statnbr := statnbr + 1 ;
2606               WITH mapptr^[statnbr] DO
2607                 BEGIN
2608                   IF (oldline = sttline)
2609                     AND (oldic <> ic)
2610                     AND (oldfile = sttfile)
2611                     AND (oldindex <> sttindex) THEN
2612                     sttinline := sttinline + 1
2613                   ELSE
2614                     BEGIN
2615                       sttinline := 1 ;
2616                       oldfile := sttfile ;
2617                       oldline := sttline ;
2618                     END ;
2619                   oldic := ic ;
2620                   oldindex := sttindex ;
2621                   word1 := (sttfile * twoto10) + (sttline DIV twoto4) ;
2622                   locic := sttplace DIV bytesinword ;
2623                   insert_ (locic, 18, word1) ;
2624                   word2 := (sttinline * twoto27) + (sttindex * twoto9) + (sttlength MOD 256) ;
2625                   insert_ ((sttline MOD twoto4), 32, word2) ;
2626                 END ;
2627               end_statement := true ;
2628             END ;
2629       END (* STATEMENT ENDS *) ;
2630 $OPTIONS page $
2631 
2632 (* *************************************************** NAMEISREF ************************ *)
2633 
2634     PROCEDURE nameisref (box : ctp ; fil, lin : integer) ;
2635 
2636 (* C FILLS REF STRUCTURE WHEN NAME IS REFERENCED                      C *)
2637 
2638       VAR
2639         refbox : refptr ;
2640 
2641       BEGIN
2642         IF NOT building_from_schema.on THEN
2643           WITH box^ DO
2644             BEGIN
2645               IF klass = vars THEN visrefincode := (NOT declarationpart)
2646               ELSE IF klass = proc THEN pisrefincode := (NOT declarationpart) AND (NOT procisactive) ;
2647               refbox := references ;
2648               IF refbox <> NIL THEN BEGIN
2649                   IF refbox^.refnbr = maxref THEN BEGIN
2650                       new (refbox) ;
2651                       WITH refbox^ DO
2652                         BEGIN
2653                           nextref := references ;
2654                           references := refbox ;
2655                           refnbr := 1
2656                         END ;
2657                     END
2658                   ELSE
2659                     WITH refbox^ DO
2660                       refnbr := refnbr + 1 ;
2661                   WITH refbox^ DO
2662                     WITH refs [refnbr] DO BEGIN
2663                         filen := fil ;
2664                         linen := lin ;
2665                         IF (environt = code) AND (NOT declarationpart) THEN sttmapind := statnbr * 2
2666                         ELSE IF lin < 0 THEN sttmapind := -1
2667                           ELSE sttmapind := -2 ;
2668                       END ;
2669                 END ;
2670             END ;
2671 
2672       END (* NAMEISREF *) ;
2673 
2674 $OPTIONS page $
2675 
2676 (* ***********************************************SKIP************************* *)
2677 
2678     PROCEDURE skip ;
2679 
2680 (* C   THIS PROCEDURE IS USED  FOR ERROR'S  RECOVERY  MECHANISM.
2681    SKIPS ALL IRRELEVANT SYMBOLS DEFINED IN ERRCL
2682    STOPS ON  BEGSYMBOL,  ENDSYMBOL   OR  SPECIFIED 'NOSYMB'
2683    C *)
2684       BEGIN
2685 $OPTIONS compile = trace $
2686         IF anytrace > none THEN
2687           BEGIN
2688             write (mpcogout, ' @@@ DEBUT SKIP @@@  WITH  NOSYMB= ', nosymb : 4) ; nextline ;
2689           END ;
2690 $OPTIONS compile = true $
2691         WHILE (errcl [no] = irrelsy) AND (nosymb # no) AND NOT eof (mpcogin) DO
2692           IF (no = 38) AND (cl = 2) (* RECORD *) THEN
2693             BEGIN
2694               REPEAT
2695                 insymbol ; skip (46) ;            (* NON ASSIGNED VALUE *)
2696               UNTIL NOT (no IN [16, 26]) ;        (* ; CASE *)
2697               IF no = 22 (* END *) THEN
2698                 insymbol ;
2699             END ELSE
2700             insymbol ;
2701 $OPTIONS compile = trace $
2702         IF anytrace > low THEN
2703           BEGIN
2704             write (mpcogout, ' @@@ FIN SKIP  @@@ ') ; nextline ;
2705           END ;
2706 $OPTIONS compile = true $
2707       END (* SKIP *) ;
2708 
2709 $OPTIONS page $
2710 
2711 (* ***********************************************      SKIPEXTD       *)
2712 
2713     PROCEDURE skipextd ;
2714 
2715 (* C   THIS PROCEDURE IS USED  FOR ERROR'S  RECOVERY  MECHANISM.
2716    SKIPS ALL IRRELEVANT SYMBOLS DEFINED IN ERRCL
2717    STOPS ON  BEGSYMBOL,  ENDSYMBOL   OR  SPECIFIED 'NOSYMB'S
2718    C *)
2719       VAR
2720         it : integer ;
2721 
2722       BEGIN                                       (* SKIPEXTD *)
2723 $OPTIONS compile = trace $
2724         IF anytrace > none THEN
2725           BEGIN
2726             write (mpcogout, ' @@@ DEBUT SKIPEXTD @@@  WITH  NOSYMB= ') ;
2727             FOR it := minno TO maxno DO
2728               IF it IN nosymb THEN
2729                 write (mpcogout, it : 4) ;
2730             nextline ;
2731           END ;
2732 $OPTIONS compile = true $
2733         WHILE (errcl [no] = irrelsy) AND NOT (no IN nosymb) DO
2734           IF (no = 38) AND (cl = 2) (* RECORD *) THEN
2735             BEGIN
2736               REPEAT
2737                 insymbol ; skip (46) ;            (* NON ASSIGNED VALUE *)
2738               UNTIL NOT (no IN [16, 26]) ;        (* ; CASE *)
2739               IF no = 22 (* END *) THEN
2740                 insymbol ;
2741             END ELSE
2742             insymbol ;
2743 $OPTIONS compile = trace $
2744         IF anytrace > low THEN
2745           BEGIN
2746             write (mpcogout, ' @@@ FIN SKIPEXTD  @@@ with NO', no : 4) ; nextline ;
2747           END ;
2748 $OPTIONS compile = true $
2749       END (* SKIPEXTD *) ;
2750 
2751 $OPTIONS page $
2752 
2753 (* ***********************************************      SKIPTOCHAPTER       *** *)
2754 
2755     PROCEDURE skiptochapter ;
2756 
2757 (* C   THIS PROCEDURE IS USED  FOR ERROR'S  RECOVERY  MECHANISM.
2758    SKIPS ALL IRRELEVANT SYMBOLS
2759    STOPS ON PROGRAM $RENAME $IMPORT $EXPORT LABEL CONST
2760    TYPE VAR $VALUE PROCEDURE FUNCTION BEGIN
2761    C *)
2762       BEGIN                                       (* SKIPTOCHAPTER *)
2763 $OPTIONS compile = trace $
2764         IF anytrace > none THEN
2765           BEGIN
2766             write (mpcogout, ' @@@ DEBUT SKIPTOCHAPTER @@@  ') ; nextline ;
2767           END ;
2768 $OPTIONS compile = true $
2769         WHILE NOT (no IN [50, 51, 52, 53, 40, 41, 37, 43, 54, 44, 45, 21]) DO
2770           insymbol ;
2771 $OPTIONS compile = trace $
2772         IF anytrace > low THEN
2773           BEGIN
2774             write (mpcogout, ' @@@ FIN SKIPTOCHAPTER  @@@ ') ; nextline ;
2775           END ;
2776 $OPTIONS compile = true $
2777       END (* SKIPTOCHAPTER *) ;
2778 
2779 
2780 $OPTIONS page $
2781 
2782 (* ***********************************************INCONST********************** *)
2783 
2784     PROCEDURE inconst (VAR code : integer ; VAR restype : ctp ; fnxt : ctp ; expression_allowed : boolean) ;
2785 
2786 (* C  THIS PROCEDURE IS CALLED IN ORDER  TO ANALYSE  A CONSTANTE
2787    .CODE       IS A CODE  FOR THE  CONSTANTE
2788    1    VALUE IN "CONINT"                        5:SCALAR
2789    2    VALUE  IN "CONREEL"                      0:ERROR
2790    3    VALUE IN "BUFVAL" WITH LENGTH "LONGSTRING"
2791    4    VALUE  IN "CONINT"  (CHARPTR)
2792    .RESTYPE    TYPE OF CONSTANTE
2793    .FNXT     IS  CTP BEGINNING OF SEARCH  IN  CONTEXTTABLE              C *)
2794 (* E    50  ERROR IN CONSTANT
2795    60  OR NOT ALLOWED AS MONADIC OPERATOR
2796    103  IDENTIFIER IS NOT OF APPROPRIATE CLASS
2797    104  IDENTIFIER NOT DECLARED
2798    144 : ILLEGAL TYPE OF EXPRESSION
2799    225 : THIS EXPRESSION CANNOT BE EVALUATED HERE : IT NEEDS CODE GENERATION
2800    105  SIGN NOT ALLOWED                                                  E *)
2801       VAR
2802         sign, isno7 : boolean ;
2803         savectptr : ctp ;
2804         it, jt : integer ;
2805         curbox : alfapt ;
2806         whattrace : levtrace ;
2807       BEGIN
2808 $OPTIONS compile = trace $
2809         IF decltrace > stattrace THEN whattrace := decltrace ELSE
2810           whattrace := stattrace ;
2811         IF whattrace > none THEN
2812           BEGIN
2813             write (mpcogout, ' @@@ DEBUT INCONST @@@  FNXT IS ', ord (fnxt)) ; nextline ;
2814             IF whattrace = high THEN
2815               BEGIN
2816                 write (mpcogout, ' GLOBALS NO,CL,IVAL,RVAL ARE ', no : 4, cl : 4, ival, rval) ;
2817                 nextline ;
2818               END ;
2819           END ;
2820 $OPTIONS compile = true $
2821         restype := NIL ;                          (* DEFAULT = ERROR *)
2822         IF expression_allowed AND (envstandard = stdextend) THEN
2823           BEGIN
2824             illegal_generation := false ;
2825             initattrvarbl (gattr) ; freeallregisters ;
2826             expression ;
2827             IF illegal_generation THEN error (225) ;
2828             WITH gattr DO
2829               IF (NOT (kind IN [sval, chain])) OR (typtr = NIL) THEN
2830                 BEGIN
2831                   IF (NOT illegal_generation) AND (typtr <> NIL) THEN error (225) ;
2832                   restype := NIL ; conint := 0
2833                 END
2834               ELSE
2835                 IF kind = sval THEN
2836                   BEGIN
2837                     IF (typtr = intptr) OR
2838                       (typtr^.form = scalar) OR
2839                       (typtr = charptr) THEN
2840                       BEGIN
2841                         restype := typtr ; conint := val
2842                       END ELSE
2843                       IF typtr = realptr THEN
2844                         BEGIN
2845                           restype := realptr ; conreel := rsval
2846                         END ELSE
2847                         BEGIN
2848                           error (144) ;
2849                           restype := NIL ; conint := 0
2850                         END
2851                   END ELSE
2852                   BEGIN
2853                     restype := alfaptr ;
2854                     longstring := 0 ;
2855                     IF alfactp <> NIL THEN
2856                       WITH alfactp^ DO
2857                         BEGIN
2858                           curbox := alfadeb ; longstring := 0 ;
2859                           FOR it := 1 TO alfalong DIV longalfbox DO
2860                             BEGIN
2861                               FOR jt := 1 TO longalfbox DO
2862                                 BEGIN
2863                                   bufval [longstring + jt] := curbox^.alfaval [jt] ;
2864                                 END ;
2865                               longstring := longstring + longalfbox ;
2866                               curbox := curbox^.nextval ;
2867                             END ;
2868                           FOR it := 1 TO alfalong MOD longalfbox DO
2869                             BEGIN
2870                               longstring := longstring + 1 ;
2871                               bufval [longstring] := curbox^.alfaval [it] ;
2872                             END ;
2873                         END
2874                   END
2875           END
2876         ELSE
2877           BEGIN                                   (* NOT EXPRESSION *)
2878             IF no = 7 (* + - OR *) THEN
2879               BEGIN
2880                 sign := cl = 2 ;
2881                 IF cl = 3 THEN error (60) ;
2882                 isno7 := true ;
2883                 insymbol ;
2884               END ELSE
2885               BEGIN
2886                 sign := false ;
2887                 isno7 := false ;
2888               END ;
2889             IF no = 2 THEN                        (* EXPLICIT CONST *)
2890               BEGIN
2891                 IF (cl > 2) AND isno7 THEN error (105) ;
2892                 CASE cl OF
2893                   1 : BEGIN
2894                       restype := intptr ;
2895                       IF sign THEN conint := -ival ELSE conint := ival ;
2896                     END ;
2897                   2 : BEGIN
2898                       restype := realptr ;
2899                       IF sign THEN conreel := -rval ELSE conreel := rval ;
2900                     END ;
2901                   3 : BEGIN
2902                       restype := alfaptr ;
2903                       longstring := longchaine ;
2904                     END ;
2905                   4 : BEGIN
2906                       restype := charptr ;
2907                       conint := ival ;
2908                     END ;
2909                 END (* CASE *) ;
2910                 insymbol ;
2911               END (* NO=2 *) ELSE
2912               IF no = 1 (* CONSTANT IDENTIFIER *) THEN
2913                 BEGIN
2914                   savectptr := ctptr ;
2915                   srchrec (fnxt) ;
2916                   IF ctptr = NIL THEN search ;
2917                   IF ctptr = NIL THEN error (104) ELSE
2918                     BEGIN
2919                       IF symbolmap THEN nameisref (ctptr, symbolfile, symbolline) ;
2920                       WITH ctptr@ DO
2921                         BEGIN                     (* IDENTIFIER FOUND IN CONTEXTABLE *)
2922                           IF klass # konst THEN error (103) ELSE
2923                             BEGIN
2924                               restype := contype ;
2925                               IF restype = intptr THEN
2926                                 IF sign THEN conint := -values ELSE conint := values
2927                               ELSE
2928                                 IF restype = realptr THEN
2929                                   IF sign THEN conreel := -valreel ELSE conreel := valreel
2930                                 ELSE
2931                                   BEGIN           (* CHAR,SCALAR OR ALFA CONST *)
2932                                     IF isno7 THEN error (105) ;
2933                                     IF restype = alfaptr THEN
2934                                       BEGIN
2935                                         curbox := alfadeb ; longstring := 0 ;
2936                                         FOR it := 1 TO alfalong DIV longalfbox DO
2937                                           BEGIN
2938                                             FOR jt := 1 TO longalfbox DO
2939                                               BEGIN
2940                                                 bufval [longstring + jt] := curbox@.alfaval [jt] ;
2941                                               END ;
2942                                             longstring := longstring + longalfbox ;
2943                                             curbox := curbox@.nextval ;
2944                                           END ;
2945                                         FOR it := 1 TO alfalong MOD longalfbox DO
2946                                           BEGIN
2947                                             longstring := longstring + 1 ;
2948                                             bufval [longstring] := curbox@.alfaval [it] ;
2949                                           END ;
2950                                       END (* ALFA *) ELSE (* CHAR OR SCALAR *)
2951                                       conint := values ;
2952                                   END ;           (* CHAR,SCALAR OR ALFA *)
2953                             END ;                 (* KONST *)
2954                         END ;                     (* WITH CTPTR *)
2955                     END ;
2956                   ctptr := savectptr ;            (* RESTORE CTPTR *)
2957                   insymbol ;
2958                 END (* IDENTIFIER *) ELSE
2959                 error (50) ;
2960           END (* NOT EXPRESSION *) ;
2961         IF restype = NIL THEN code := 0 ELSE
2962           IF restype = intptr THEN code := 1 ELSE
2963             IF restype = realptr THEN code := 2 ELSE
2964               IF restype = alfaptr THEN code := 3 ELSE
2965                 IF restype = charptr THEN code := 4 ELSE
2966                   code := 5 ;
2967 $OPTIONS compile = trace $
2968         IF whattrace > low THEN
2969           BEGIN
2970             IF whattrace = high THEN
2971               BEGIN
2972                 write (mpcogout, 'GLOBALS  CONINT,CONREEL ,LONGSTRING  ARE', conint, conreel,
2973                   longstring) ; nextline ;
2974               END ;
2975             write (mpcogout, ' @@@ FIN INCONST @@@ WITH  V.CODE,V.RESTYPE = ', code : 3,
2976               ord (restype)) ; nextline ;
2977           END ;
2978 $OPTIONS compile = true $
2979       END (* INCONST *) ;
2980 
2981 
2982 
2983 
2984 
2985 $OPTIONS page $
2986 
2987 (* ***********************************************CARTEEXEC ******************* *)
2988 
2989     PROCEDURE carteexec ;
2990 
2991 (* C  MUST BE CALLED  AFTER INITIALISE ;  BEFORE  FIRST INSYMBOL;
2992    SCANS  $PARM   IN ORDER   TO
2993    ASSIGN   TRACE'S VARIABLES
2994    STANDARD
2995    NOTRACE
2996    SYMBTABL
2997    XREFNEED                                                   C *)
2998       CONST
2999         count = 100 ;
3000       VAR
3001         lfound : boolean ;
3002         lch : char ;
3003         lastread : integer ;
3004         parmlist : PACKED ARRAY [1..count] OF char ;
3005 
3006 
3007 (* *************************************SCANPARM < CARTEEXEC ****************** *)
3008 
3009       PROCEDURE scanparm (fstring : alfa ; flong : integer ; VAR strisfound : boolean ;
3010         VAR nextchar : char) ;
3011 
3012 (* C  SCANS IN PARMLIST ON 'FSTRING'  ON'FLONG'  CHARS;
3013    IF  FOUND   RETURNS 'STRISFOUND ' TRUE    AND   THE  NEXTCHAR
3014    IF  NOT     RETURNS               FALSE
3015    C *)
3016         LABEL
3017           1 ;                                     (* EXIT  LOOP FOR *)
3018         VAR
3019           i, j : integer ;
3020           lalf : alfa ;
3021         BEGIN
3022                                                   (*  DEFAULT  VALUES *)
3023           strisfound := false ; nextchar := ' ' ;
3024           lalf := blank ;
3025           FOR i := 0 TO count - flong DO
3026             BEGIN
3027               FOR j := 1 TO flong DO
3028                 lalf [j] := parmlist [i + j - 1] ;
3029               IF lalf = fstring THEN
3030                 BEGIN
3031                   strisfound := true ;
3032                   IF i <= (count - flong) THEN
3033                     BEGIN lastread := i + flong ;
3034                       nextchar := parmlist [lastread] ;
3035                     END ;
3036                   GOTO 1 ;                        (* EXIT  LOOP(S) *)
3037                 END ;
3038             END ;
3039 1 :                                               (* EXIT  LOOP  FOR *)
3040         END (* SCANPARM *) ;
3041 
3042 
3043       BEGIN                                       (* CARTEEXEC *)
3044         checks := true ;
3045         argv (1, parmlist) ;
3046         scanparm ('FAST    ', 4, lfound, lch) ;
3047         IF lfound THEN fastoperator := true ;
3048         scanparm ('PRCODE  ', 6, lfound, lch) ;
3049         IF lfound THEN codelist := true ;
3050         scanparm ('REFS    ', 4, lfound, lch) ;
3051         IF lfound THEN symbolmap := true ;
3052         scanparm ('LIST    ', 4, lfound, lch) ;
3053         IF lfound THEN
3054           BEGIN
3055             listyes := true ;
3056             symbolmap := true ;
3057             symbol_listing := true ;
3058             mapswitch := true
3059           END ;
3060         scanparm ('SKIPCODE', 8, lfound, lch) ;
3061         IF lfound THEN
3062           skipcode := true ;                      (* CONDITIONAL  COMPILATION  *)
3063         scanparm ('NOCHECKS', 8, lfound, lch) ;
3064         IF lfound THEN
3065           BEGIN
3066             checks := false ;
3067             tsetinargs := true ;
3068           END ;
3069         scanparm ('NOSTAND ', 7, lfound, lch) ;
3070         IF lfound THEN
3071           envstandard := stdextend ;
3072         scanparm ('STDSOL', 6, lfound, lch) ;
3073         IF lfound THEN
3074           BEGIN
3075             envstandard := stdsol ;
3076           END ;
3077         scanparm ('STRACE= ', 7, lfound, lch) ;
3078         IF lfound THEN
3079           BEGIN
3080             tracelevel (stattrace, lch) ;
3081             wssetinargs := true ;
3082           END ;
3083         scanparm ('DTRACE= ', 7, lfound, lch) ;
3084         IF lfound THEN
3085           BEGIN
3086             tracelevel (decltrace, lch) ;
3087             wdsetinargs := true ;
3088           END ;
3089         scanparm ('INTER', 5, lfound, lch) ;
3090         IF lfound THEN
3091           interactive := true ;
3092         scanparm ('NOIOW', 5, lfound, lch) ;
3093         IF lfound THEN
3094           iowarnings := false ;
3095         scanparm ('GTRACE= ', 7, lfound, lch) ;
3096         IF lfound THEN
3097           BEGIN
3098             tracelevel (genetrace, lch) ;
3099             wgsetinargs := true ;
3100           END ;
3101         scanparm ('FRENC', 5, lfound, lch) ;
3102         IF lfound THEN
3103           BEGIN
3104             pascalfrench := true ;
3105             wd := wdf ; wno := wnof ; wcl := wclf ; wl1 := wl1f ; wl2 := wl2f ;
3106             usednames := usednamesf ;
3107           END ELSE
3108           BEGIN
3109             pascalfrench := false ;
3110             wd := wda ; wno := wnoa ; wcl := wcla ; wl1 := wl1a ; wl2 := wl2a ;
3111             usednames := usednamesa ;
3112           END ;
3113         scanparm ('TABLE   ', 5, lfound, lch) ;
3114         IF lfound THEN
3115           BEGIN
3116             symbtabl := true ;
3117             mapswitch := true
3118           END ;
3119         scanparm ('BRIEFTB ', 7, lfound, ch) ;
3120         IF lfound THEN
3121           BEGIN
3122             brieftable := true ;
3123             mapswitch := true
3124           END ;
3125         scanparm ('LONGPROF', 8, lfound, ch) ;
3126         IF lfound THEN
3127           BEGIN
3128             longprofile := true ;
3129             mapswitch := true
3130           END ;
3131         scanparm ('PROFILE ', 7, lfound, ch) ;
3132         IF lfound THEN
3133           BEGIN
3134             profile := true ;
3135             mapswitch := true
3136           END ;
3137         scanparm ('BRIEFMAP', 8, lfound, ch) ;
3138         IF lfound THEN
3139           BEGIN
3140             listyes := true ;
3141             mapswitch := true
3142           END ;
3143         scanparm ('LP      ', 2, lfound, lch) ;
3144         IF lfound THEN
3145           BEGIN                                   (* 2 DIGITS COMING NOW *)
3146             pagelength := (ord (lch) - ord ('0')) * 10 ;
3147             pagelength := pagelength + ord (parmlist [lastread + 1]) - ord ('0') ;
3148           END ;
3149         scanparm ('XREF    ', 4, lfound, lch) ;
3150         IF lfound THEN
3151           xrefneed := true ;
3152         outcode := writecode OR (genetrace > none) ;
3153 $OPTIONS compile = trace $
3154         IF decltrace > none THEN
3155           BEGIN
3156             write (mpcogout, 'SKIPCODE,STATTRACE,DECLTRACE,GENETRACE,SYMBTABL,XREF',
3157               skipcode, ord (stattrace), ord (decltrace), ord (genetrace),
3158               symbtabl, xrefneed) ;
3159             nextline
3160           END ;
3161 $OPTIONS compile = true $
3162       END (* CARTEEXEC *) ;
3163 
3164 $OPTIONS page $
3165 
3166 (* ********************************************************** VERIFCOHERENCE    ** *)
3167 
3168 $OPTIONS compile = security $
3169     PROCEDURE verifcoherence ;
3170 
3171 (* C
3172    On verifie que les relations qui doivent exister entre les constantes
3173    se maintiennent de VERSION en VERSION.
3174    C *)
3175 
3176 (* E ERRORS DETECTED
3177    439 Premier groupe
3178    440 Second   "
3179    441 Troisieme "
3180    E *)
3181       BEGIN
3182         IF (confdimsize <> confdimw * bytesinword) OR
3183           (eofb <> eofw * bytesinword) OR
3184           (eolnb <> eolnw * bytesinword) OR
3185           (lgparm <> lgparm1 + 1) THEN error (439) ;
3186         IF (maxset + 1 <> setrange) OR
3187           (maxchar > maxset) OR
3188           (maxerrnum <> 3 * setrange - 1) OR
3189           (maxpage <> maxerrnum) OR
3190           (maxerpg + 1 < (maxpage DIV setrange)) THEN error (440) ;
3191         IF (bitsforset <> bytesforset * bitsinbyte) OR
3192           (bytesforset <> wordsforset * bytesinword) OR
3193           (wordsforset <> bornesupset + 1) THEN error (441) ;
3194 
3195       END ;
3196 
3197 $OPTIONS compile = true $
3198 
3199 $OPTIONS page $
3200 
3201 (* *************************************COMPILER'S  MAIN*********************** *)
3202 
3203     BEGIN                                         (* MAIN *)
3204       listyes := false ;
3205       new (fichinter) ; IF fichinter = NIL THEN heaperror ;
3206       rewrite (mpcogout) ;
3207       initialise ;
3208       carteexec ;
3209       IF mapswitch THEN BEGIN
3210           getmapptr (mapptr) ;
3211           getprofptr (profptr) ;
3212           IF profile THEN profilewordcount := phl ;
3213           IF longprofile THEN profilewordcount := lphl ;
3214         END ;
3215                                                   (* IF symbtabl THEN *) lkc := lkc + (2 * bytesinword) ;
3216       IF listyes THEN
3217         BEGIN
3218           listhead ;
3219           pageno := pageno + 1 ;
3220           iligne := 9 ;
3221           nextline ;
3222         END ;
3223       asscheck := checks ; divcheck := checks ; inxcheck := checks ;
3224       IF eof (mpcogin) THEN
3225         BEGIN
3226           error (22) ; GOTO 100 ;
3227         END ELSE nextch ;
3228 $OPTIONS compile = security $
3229       verifcoherence ;
3230 $OPTIONS compile = true $
3231       progdecl ;                                  (* BEFORE CALL OF INITCLASS *)
3232       initclasse ;
3233                                                   (* display[0].fname := next; In INITCLASSE *)
3234 
3235       lc := xc ;
3236       WITH display [1] DO
3237         BEGIN
3238           fname := NIL ; occur := block ;
3239         END ;
3240       top := 1 ;
3241       level := 0 ;
3242       create_dummyclass_box (pt, blank) ;
3243       next := NIL ;
3244       IF inputflag # NIL THEN
3245         BEGIN
3246           create_vars_box (inputctp, usednames [1]) ;
3247           WITH inputctp^ DO
3248             BEGIN
3249               vtype := textfilectp ; vkind := imported ; vlevel := 0 ;
3250               vaddr := -1 ; vptextitem := inputflag ;
3251               visused := true ; vfilelocation := standardfile ; visset := true ;
3252               deffile := inputflag^.extrfile1 ; defline := inputflag^.extrline1 ;
3253               IF symbolmap THEN
3254                 IF inputflag^.extrline2 <> 0 THEN
3255                   nameisref (inputctp, inputflag^.extrfile2, inputflag^.extrline2) ;
3256             END ;
3257           next := inputctp ; filtop := filtop + 1 ;
3258           inputflag^.extdecl := inputctp ;
3259           filpts [filtop] := inputctp ;
3260         END (* INPUTFLAG *) ;
3261       IF outputflag # NIL THEN
3262         BEGIN
3263           create_vars_box (outputctp, usednames [2]) ;
3264           WITH outputctp^ DO
3265             BEGIN
3266               vtype := textfilectp ; vkind := imported ; vlevel := 0 ;
3267               vaddr := -1 ; vptextitem := outputflag ;
3268               visused := true ; vfilelocation := standardfile ;
3269               deffile := outputflag^.extrfile1 ; defline := outputflag^.extrline1 ;
3270               IF symbolmap THEN
3271                 IF outputflag^.extrline2 <> 0 THEN
3272                   nameisref (outputctp, outputflag^.extrfile2, outputflag^.extrline2) ;
3273             END ;
3274           next := outputctp ; filtop := filtop + 1 ;
3275           outputflag^.extdecl := outputctp ;
3276           filpts [filtop] := outputctp ;
3277         END (* OUTPUTFLAG *) ;
3278       IF errorflag # NIL THEN
3279         BEGIN
3280           create_vars_box (errorctp, usednames [3]) ;
3281           WITH errorctp^ DO
3282             BEGIN
3283               vtype := textfilectp ; vkind := imported ; vlevel := 0 ;
3284               vaddr := -1 ; vptextitem := errorflag ;
3285               visused := true ; vfilelocation := standardfile ;
3286               deffile := errorflag^.extrfile1 ; defline := errorflag^.extrline1 ;
3287               IF symbolmap THEN
3288                 IF errorflag^.extrline2 <> 0 THEN
3289                   nameisref (errorctp, errorflag^.extrfile2, errorflag^.extrline2) ;
3290             END ;
3291           next := errorctp ; filtop := filtop + 1 ;
3292           errorflag^.extdecl := errorctp ;
3293           filpts [filtop] := errorctp ;
3294         END (* ERRORFLAG *) ;
3295 
3296 
3297 
3298       new (programnode, procblock) ;              (* ROOTNODE *)
3299       currentnode := programnode ;
3300       WITH programnode^ DO BEGIN
3301           father := NIL ;
3302           brother := NIL ;
3303           son := NIL ;
3304           nextproc := NIL ;
3305           blockbox := NIL ;
3306           codebegin := 0 ;
3307           codeend := 0 ;
3308           structureplace := 0 ;
3309           first := NIL ;
3310           firstlabel := NIL ;
3311           blocktp := procblock ;
3312           hdrlin := hdrline ;
3313           hdrfil := hdrfile ;
3314           hdrlen := hdrlength ;
3315           hdrind := hdrindex ;
3316         END ;
3317 
3318 (* *********************************
3319    *                                *)
3320 
3321       body (NIL, pt) ;
3322       IF no # 17 THEN error (24) ;
3323 
3324 (*                               *
3325    ********************************* *)
3326 
3327       compencours := false ;
3328       REPEAT
3329         nextch ;
3330       UNTIL compencours ;                         (* ARTIFICIAL EXIT VIA *)
3331                                                   (* GOTO 100 IN NEXTCH *)
3332 100 :                                             (* END OF COMPILATION *)
3333       IF mapswitch THEN
3334         statement_ends (0) ;
3335       wkextpt := externallistheader ;
3336       err149 := false ;
3337       WHILE wkextpt <> NIL DO
3338         BEGIN
3339 
3340           IF wkextpt^.extdecl = NIL THEN
3341             IF wkextpt^.extitemtype IN [extnotresolved, remanentfile] THEN
3342               BEGIN
3343                 IF NOT err149 THEN
3344                   BEGIN
3345                     err149 := true ;
3346                     error (149) ; printerr ;
3347                   END ;
3348                 IF listyes THEN write (mpcogout, '  NOT REDEFINED EXTERNAL NAME(S) :',
3349                     wkextpt^.extname : maxident + 1) ; nextline ;
3350                 writeln (mpcogerr, '  NOT REDEFINED EXTERNAL NAME(S) :',
3351                   wkextpt^.extname : maxident + 1) ;
3352               END ;
3353           wkextpt := wkextpt^.extnext ;
3354         END ;
3355       IF programnode <> NIL THEN
3356         programnode^.codeend := statnbr * 2 ;
3357       IF nbccond # 0 THEN error (208) ;
3358       IF errinx > 0 THEN
3359         printerr ;
3360       statistiques ;
3361       linkswordcount := lkc DIV bytesinword ;
3362       IF mapswitch THEN BEGIN                     (* END STATEMENT MAP *)
3363           statnbr := statnbr + 1 ;
3364           WITH mapptr^[statnbr] DO
3365             BEGIN
3366               word1 := twoto18 - 1 ;
3367               insert_ (ic DIV bytesinword, 18, word1) ;
3368               word2 := 0 ;
3369               insert_ (-1, 27, word2) ;
3370             END ;
3371           IF profile THEN BEGIN
3372               insert_ ((statnbr - 1) * 2, 18, profptr^[profilewordcount]) ;
3373               profilewordcount := profilewordcount + pclength
3374             END ;
3375         END ;
3376       IF errtotal = 0 THEN buildobject ;
3377       IF errtotal <> 0 THEN
3378         BEGIN
3379           IF mapswitch THEN
3380             displaysources ;
3381           IF symbol_listing THEN
3382             IF programnode <> NIL THEN displaysymbols ;
3383         END ;
3384       reset (fichinter) ;
3385       stop (errtotal) ;                           (* RETURN CODE  #0 IF COMP ERRORS *)
3386     END (* END OF MAIN PROGRAM FOR PASCAL COMPILER ********************* *).