sources/pass1/wan3.f

   1 C    Loglan82 Compiler&Interpreter
   2 C     Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3 C     Copyright (C)  1993, 1994 LITA, Pau
   4 C
   5 C     This program is free software; you can redistribute it and/or modify
   6 C     it under the terms of the GNU General Public License as published by
   7 C     the Free Software Foundation; either version 2 of the License, or
   8 C     (at your option) any later version.
   9 C
  10 C     This program is distributed in the hope that it will be useful,
  11 C     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 C     GNU General Public License for more details. File: LICENSE.GNU
  14 C  ===============================================================
  15
  16       SUBROUTINE E11
  17       IMPLICIT INTEGER (A-Z)
  18 C
  19 C  RECOGNIZES SYNTACTICAL UNIT - CREATES THE PROTOTYPE
  20 C   STACK(TOP+3) - ADDRESS OF THE CURRENT PROTOTYPE
  21 C                  INITIALLY 1 FOR VIRTUAL, 0 OTHERWISE
  22 C   STACK(TOP+4) - UNIT NAME
  23 C                  FOR A BLOCK - ITS PREFIX SEND FROM E8
  24 C   STACK(TOP+5) - PREFIX (IF ONE OCCURRED)
  25 C   STACK(TOP+6) - PROTOTYPE NUMBER
  26 C
  27 C----------------------------------------------------------------------
  28 C  PROTOTYPE - STRUCTURE:
  29 C
  30 C   -5 ! NOT USED
  31 C  ----+------------------------
  32 C   -4 ! SIGNAL LIST
  33 C  ----+------------------------
  34 C   -3 ! INTERMEDIATE CODE BLOCK NUMBER
  35 C  ----+------------------------
  36 C   -2 ! INTERMEDIATE CODE WORD NUMBER IN A BLOCK
  37 C  ----+------------------------
  38 C   -1 ! 0 = NO ENUMERATION CONSTANTS
  39 C  ----+------------------------
  40 C    0 ! KIND
  41 C  ----+------------------------
  42 C   +1 ! SL - NUMBER IN ISDICT
  43 C  ----+------------------------
  44 C   +2 ! PREFIX - NAME
  45 C  ----+------------------------
  46 C   +3 ! VARIABLE LIST
  47 C  ----+------------------------
  48 C   +4 ! CONSTANT LIST
  49 C  ----+------------------------
  50 C   +5 ! CLASS LIST
  51 C  ----+------------------------
  52 C   +6 ! THE LIST OF BLOCKS, FUNCTIONS AND PROCEDURES
  53 C  ----+------------------------
  54 C   +7 ! TAKEN LIST
  55 C  ----+------------------------
  56 C   +8 ! SYSTEM PREFIX
  57 C  ----+------------------------
  58 C   +9 ! SOURCE TEXT LINE NUMBER
  59 C  ----+------------------------
  60 C    REMAINDER FOR FUNCTIONS, PROCEDURES AND CLASSES
  61 C  ----+------------------------
  62 C  +10 ! NAME
  63 C  ----+------------------------
  64 C  +11 ! FORMAL PARAMETER LIST
  65 C  ----+------------------------
  66 C    REMAINDER FOR FUNCTIONS                   REMAINDER FOR CLASSES
  67 C  ----+------------------------             ----+-----------------
  68 C  +12 ! NAME OF RESULT TYPE                 +12 ! HIDDEN LIST
  69 C  ----+------------------------             ----+-----------------
  70 C  +13 ! NUMBER OF ARRAYOF'S                 +13 ! CLOSE LIST
  71 C  ----+------------------------             ----+-----------------
  72 C
  73 C  WHERE KIND =
  74 C 1 - BLOCK
  75 C 2 - CLASS/COROUTINE/PROCESS
  76 C 3 - PROCEDURE
  77 C 4 - FUNCTION
  78 C 5 - "3" WITH ERRONEOUS PARAMETER LIST
  79 C 6 - "4" "      "       "       "
  80 C 7 - "2" "      "       "       "
  81 C        SYSTEM PREFIX =
  82 C 2 - PROCESS
  83 C 1 - COROUTINE
  84 C 0 - OTHER
  85 C        THE SYSTEM PREFIX IS AUGMENTED BY
  86 C 2**13 - IF INSTRUCTIONS ARE PRESENT
  87 C 2**14 - FOR SPECIFICATION TAKEN NONE
  88 C 2**15 - FOR SPECIFICATION VIRTUAL
  89 C
  90 C LIST ITEM FOR TAKEN, CLOSE, HIDDEN:
  91 C
  92 C   0 ! NAME
  93 C  ---+--------------------------
  94 C  +1 ! OCCURRENCE LINE NUMBER IN THE SOURCE TEXT
  95 C  ---+--------------------------
  96 C  +2 ! THE NEXT ITEM
  97 C  ---+--------------------------
  98 C
  99 C  SUBMODULE LIST ITEM:
 100 C
 101 C   0 ! PROTOTYPE NUMBER IN THE DICTIONARY
 102 C  ---+--------------------------
 103 C  +1 ! THE NEXT ELEMENT
 104 C
 105 C
 106       COMMON /BLANK/
 107      $   C0M(4),
 108      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 109      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 110      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 111      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 112      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 113      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 114      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 115      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 116      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 117      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 118      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 119      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 120      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 121      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 122      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 123      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 124      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 125      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 126
 127       common /BLANK/
 128      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 129      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 130      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 131      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 132      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 133      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 134      N   COM(132),
 135      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 136      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 137      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 138      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 139      $   scaner(8735)
 140 cdsw $   SCANER (3735),
 141       common /BLANK/
 142      Z   TOP,      IN,       NEXT,     STACK(500),
 143      *   RESZTA(3652)
 144
 145       DIMENSION IPMEM(7890)
 146       EQUIVALENCE (IPMEM(1),SCANER(1))
 147       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
 148 C  NOTE:  FOR THE MAIN BLOCK THE ENTRY IS NON-STANDARD - IN=4 JUMP TO
 149 C         LABEL 1
 150       LOGICAL BTEST
 151       DATA SHANDL/55/
 152
 153 C  ORIGINAL GOTO-STATEMENT      ***********************************************
 154 C     GOTO (1,200,300,400,0),IN ************************  03.01.84
 155 C  CHANGED TO                   ***********************************************
 156       GOTO (1,200,300,400,1),IN
 157 C  BECAUSE LABEL 0 IS UNDEFINED ***********************************************
 158 1     STACK(TOP+3)=0
 159       STACK(TOP+5)=0
 160       STACK(TOP+6)=ISFIN
 161       ISFIN=ISFIN-1
 162 C  CHECK FOR THE MAIN BLOCK (I.E. IF IN = 5)
 163       IF (IN.EQ.5) GOTO 1460
 164       IF (S.EQ.SBLOCK) GOTO 15
 165 C                                  UNIT
 166       IF (S.NE.SVIRTUAL) GOTO 3
 167       STACK(TOP+3)=1
 168       CALL SCAN
 169 3     IF (S.NE.SIDENT) GOTO 3010
 170       STACK(TOP+4)=ADRES
 171       CALL SCAN
 172       GOTO 3030
 173 C                                  NAME MISSING
 174 3010  CALL ERROR(109)
 175       STACK(TOP+4)=0
 176 3030  IF (S.NE.SCOLON) GOTO 3050
 177       CALL SCAN
 178       GOTO 3080
 179 C                                  COLON MISSING
 180 3050  CALL ERROR(118)
 181 3080  IF (S.NE.SIDENT) GOTO 5
 182 C                                  PREFIX PRESENT
 183       STACK(TOP+5)=ADRES
 184       CALL SCAN
 185 C                                  RECOGNITION OF THE UNIT KIND
 186 5     IF (S.EQ.SFUNCT) GOTO 10
 187       IF (S.EQ.SPRCD) GOTO 12
 188       IF (S.EQ.SCLASS) GOTO 14
 189       IF (S.EQ.SCOROUT) GOTO 16
 190       CALL ERROR(119)
 191 C                                  UNKNOWN KIND
 192 C                                  IF NAME WAS PRESENT ASSUME PROCEDURE
 193       IF (STACK(TOP+4).NE.0) GOTO 12
 194 207   NEXT=0
 195       RETURN
 196 10    LPMF=LPMF-19
 197       IPMEM(LPMF+6)=4
 198       GOTO 20
 199 12    LPMF=LPMF-17
 200       IPMEM(LPMF+6)=3
 201       GOTO 20
 202 14    LPMF=LPMF-19
 203       IPMEM(LPMF+6)=2
 204       IPMEM(LPMF+14)=0
 205       GOTO 20
 206 1460  IF (S.NE.SEMICOL) GOTO 1480
 207       CALL SCAN
 208       GOTO 1460
 209 1480  IF (BTEST(C0M(2),14)) GOTO 2795
 210 15    LPMF=LPMF-15
 211       IF (STACK(TOP+1).EQ.10) CALL ERROR(119)
 212       IPMEM(LPMF+6)=1
 213       IF (LPMF.LT.LPML) CALL ERROR(199)
 214       STACK(TOP+3)=LPMF+6
 215       NEXT=STACK(TOP+3)
 216 C   A LOCAL USAGE OF VARIABLE NEXT
 217       IPMEM(NEXT+9)=LN
 218       IPMEM(NEXT+2)=STACK(TOP+4)
 219 C   PREFIX SENT FROM E8
 220       GOTO 262
 221 16    LPMF=LPMF-19
 222       IPMEM(LPMF+6)=2
 223       IPMEM(LPMF+14)=ADRES
 224 C                                  THE PROTOTYPE IS ALREADY CREATED
 225 20    CONTINUE
 226       IF (LPMF.LT.LPML) CALL ERROR(199)
 227       IF (STACK(TOP+3).EQ.1)
 228      *     IPMEM(LPMF+14)=IBSET(IPMEM(LPMF+14),15)
 229 C                                  STARTING FROM THIS POINT STACK(TOP+3)
 230 C                                  INCLUDES PROTOTYPE ADDRESS
 231       STACK(TOP+3)=LPMF+6
 232       NEXT=STACK(TOP+3)
 233 C  A LOCAL USAGE OF VARIABLE NEXT
 234       IPMEM(NEXT+9)=LN
 235       IPMEM(NEXT+10)=STACK(TOP+4)
 236       IPMEM(NEXT+2)=STACK(TOP+5)
 237       CALL SCAN
 238 C
 239 C  ANALYSIS OF THE FORMAL PARAMETERS
 240 C
 241       IF (S.NE.SLEFT) GOTO 2050
 242       CALL ADDPAR(STACK(TOP+3)+11,STACK(TOP+3))
 243       IF (S.EQ.SRIGHT) CALL SCAN
 244 2050  NEXT=STACK(TOP+3)
 245 C  NEXT LOCAL USAGE OF VARIABLE NEXT
 246 C                                  JUMP OUT IF NOT A FUNCTION
 247       IF (IPMEM(NEXT).NE.4) GOTO 25
 248       IF (S.NE.SCOLON) GOTO 2080
 249       CALL SCAN
 250       GOTO 2090
 251 C                                  COLON MISSING - ERROR
 252 2080  CALL ERROR(118)
 253 2090  STACK(TOP+4)=0
 254       IF (S.NE.SARROF) GOTO 22
 255 21    STACK(TOP+4)=STACK(TOP+4)+1
 256       CALL SCAN
 257       IF (S.EQ.SARROF) GOTO 21
 258 C                                  FUNCTION TYPE ?
 259 22    IPMEM(NEXT+13)=STACK(TOP+4)
 260       IF (S.EQ.SINT)   IPMEM(NEXT+12)=ADRES*8
 261       IF (S.EQ.SCOROUT) IPMEM(NEXT+12)=K
 262       IF (S.EQ.SIDENT)  IPMEM(NEXT+12)=ADRES
 263       IF (IPMEM(NEXT+12).EQ.0) GOTO 2250
 264       CALL SCAN
 265       GOTO 25
 266 C                                  TYPE MISSING - ERROR
 267 2250  CALL ERROR(109)
 268 25    IF (S.EQ.SEMICOL) GOTO 262
 269       CALL ERROR(102)
 270 C                                  SEMICOLON EXPECTED
 271 262   NRRE=STACK(TOP+6)
 272       IPMEM(NRRE)=NEXT
 273 C  PROTOTYPE ADDRESS IS PUT INTO THE DICTIONARY
 274       IN=TOP
 275 265   IN=STACK(IN)
 276 C                                  JUMP OUT FOR THE MAIN BLOCK
 277       IF (IN.EQ.0) GOTO 275
 278       IF (STACK(IN+1).EQ.13) GOTO 266
 279       IF (STACK(IN+1).NE.11) GOTO 265
 280 C  AN E11 (SYNTACTIC UNIT) OR E13 (HANDLER) OBJECT BEING THE SYNTACTIC FATHER
 281 C  OF THE CURRENT OBJECT HAS BEEN FOUND WITHIN THE DL-CHAIN.
 282 C  E11 - MOVE PROTOTYPE ADDRESS TO STACK('PERTINENT' TOP + 3)
 283       IN = STACK(IN)
 284       NRRE = STACK(IN+3)+6
 285       GOTO 267
 286 C  E13 - MOVE PROTOTYPE ADDRESS TO STACK('PERTINENT' TOP + 4)
 287 266   IN=STACK(IN)
 288       NRRE = STACK(IN+4)+6
 289 267   IPMEM(NEXT+1)=STACK(IN+6)
 290       LPMF=LPMF-2
 291 C   UPDATE THE SUBMODULE LIST FOR THE FATHER
 292       IF (LPMF.LT.LPML) CALL ERROR(199)
 293       IF ((IPMEM(NEXT).EQ.2).OR.(IPMEM(NEXT).EQ.7)) NRRE=NRRE-1
 294       IPMEM(LPMF+2)=IPMEM(NRRE)
 295       IPMEM(NRRE)=LPMF+1
 296       IPMEM(LPMF+1)=STACK(TOP+6)
 297       GOTO 285
 298 275   IPMEM(NEXT+1)=0
 299       IF (S.NE.SBLOCK) GOTO 287
 300 285   CALL SCAN
 301 287   IF (S.NE.STAKEN) GOTO 35
 302       CALL SCAN
 303       IF (S.EQ.SEMICOL) GOTO 29
 304 27    IF (S.NE.SIDENT) GOTO 2805
 305       LPMF=LPMF-3
 306       IF (LPMF.LT.LPML) CALL ERROR(199)
 307       IPMEM(LPMF+1)=ADRES
 308       IPMEM(LPMF+2)=LN
 309       IPMEM(LPMF+3)=IPMEM(NEXT+7)
 310       IPMEM(NEXT+7)=LPMF+1
 311       CALL SCAN
 312       IF (S.NE.SCOMA) GOTO 28
 313       CALL SCAN
 314       GOTO 27
 315 C                                ADD THE SYSPP SYSTEM PREFIX
 316 2795  CONTINUE
 317       STACK(TOP+3)=LPMF+23
 318       STACK(TOP+6)=ISFIN+1
 319       CALL SCAN
 320       GOTO 36
 321 28    IF (S.EQ.SEMICOL) GOTO 30
 322 2805  CALL ERROR(102)
 323       GOTO 35
 324 29    IPMEM(NEXT+8)=IBSET(IPMEM(NEXT+8),14)
 325 30    CALL SCAN
 326 35    IF (S.EQ.SCLOSE) GOTO 350
 327 36    NEXT=STACK(TOP+3)
 328       CALL SLAD(4,11,2)
 329       STACK(TOP+3)=NEXT
 330       NEXT=10
 331       RETURN
 332 C  CALL E10 TO ANALYSE THE DECLARATION SEQUENCE
 333 200   IF (S.EQ.SHANDL) GOTO 380
 334 203   NEXT=STACK(TOP+3)
 335       IF (S.EQ.SBEGIN) GOTO 210
 336       IF (S.EQ.SEND) GOTO 212
 337       IF (S.LT.1) GOTO 205
 338       IF (S.GT.24) GOTO 205
 339       CALL ERROR(134)
 340       GOTO 210
 341 205   IF (S.EQ.SBECOME) GOTO 210
 342       IF (IPMEM(NEXT-1).EQ.0) GOTO 209
 343 C                                    ENUMERATION CONSTANTS OCCURRED - END CODE
 344       CALL OUTPUT(WFIRST,LN)
 345       CALL OUTPUT(WFIN,1)
 346       CALL OUTPUT(LN,-1)
 347 209   CALL ERROR(113)
 348       GOTO 207
 349 210   IPMEM(NEXT+8)=IBSET(IPMEM(NEXT+8),13)
 350 212   CALL SLAD(4,11,3)
 351       STACK(TOP+3)=NEXT
 352       NEXT=9
 353       RETURN
 354 C  CALL E9 TO ANALYSE THE INSTRUCTION SEQUENCE
 355 C  E9 FILLS UP WORDS -1,-2,-3 FOR THE PROTOTYPE WHOSE
 356 C  ADDRESS IS PASSED THROUGH STACK(TOP+3)
 357 C
 358 300   IF (TOP.EQ.1) GOTO 207
 359 C
 360 C  IF IT WAS THE MAIN BLOCK JUMP OUT TO 207
 361 C
 362       CALL SCAN
 363       NEXT=STACK(TOP+3)
 364 C
 365 C  A LOCAL USAGE OF VARIABLE NEXT - IT INCLUDES THE PROTOTYPE ADDRESS.
 366 C  CHECK IF THE PARSED UNIT WAS A BLOCK. IF SO THEN JUMP OUT AND TERMINATE
 367 C  PARSING. OTHERWISE CHECK WHETHER "END" IS FOLLOWED BY AN IDENTIFIER
 368 C
 369       IF (IPMEM(NEXT).EQ.1) GOTO 207
 370       IF (S.NE.SIDENT) GOTO 207
 371 C
 372 C  "END" IS FOLLOWED BY AN IDENTIFIER. WE HAVE TO CHECK WHETHER
 373 C  IT MATCHES THE IDENTIFIER FROM THE PROTOTYPE.
 374 C
 375       NEXT=NEXT+10
 376       IF (ADRES.EQ.IPMEM(NEXT)) GOTO 308
 377       CALL ERROR(128)
 378       GOTO 207
 379 C                                  NAME IS OK
 380 308   CALL SCAN
 381       GOTO 207
 382 3460  CALL ERROR(102)
 383       GOTO 3485
 384 3470  CALL ERROR(109)
 385       GOTO 3485
 386 3480  CALL ERROR(121)
 387       CALL SCAN
 388 C                                  LOOK FOR A REASONABLE SYMBOL
 389 3485  IF (S.EQ.SBEGIN) GOTO 200
 390       IF (S.EQ.SEND) GOTO 212
 391       IF (S.EQ.SUNIT) GOTO 35
 392       IF (S.EQ.SVAR) GOTO 35
 393       IF (S.EQ.SCONS) GOTO 35
 394       IF (S.EQ.SCLOSE) GOTO 350
 395       IF (S.EQ.70) GOTO 207
 396       IF (S.EQ.1) GOTO 3488
 397       IF (S.LT.25) GOTO 200
 398 3488  CALL SCAN
 399       GOTO 3485
 400 350   NRRE=STACK(TOP+3)
 401       IF ((IPMEM(NRRE).NE.2).AND.(IPMEM(NRRE).NE.7)) GOTO 3480
 402 351   STACK(TOP+4)=ADRES
 403       CALL SCAN
 404       IF (S.NE.SCLOSE) GOTO 355
 405       IF (ADRES.EQ.STACK(TOP+4)) CALL ERROR(120)
 406       GOTO 365
 407 C  HIDDEN OR PROTECTED ENCOUNTERED
 408 355   IF (S.NE.SIDENT) GOTO 3470
 409       LPMF=LPMF-3
 410       IF (LPMF.LT.LPML) CALL ERROR(199)
 411       IPMEM(LPMF+1)=ADRES
 412       IPMEM(LPMF+2)=LN
 413       NEXT=STACK(TOP+3)+STACK(TOP+4)+11
 414       IPMEM(LPMF+3)=IPMEM(NEXT)
 415       IPMEM(NEXT)=LPMF+1
 416       CALL SCAN
 417       IF (S.EQ.SEMICOL) GOTO 30
 418       IF (S.NE.SCOMA) GOTO 3460
 419       CALL SCAN
 420       GOTO 355
 421 C  HIDDEN PROTECTED ENCOUNTERED
 422 365   CALL SCAN
 423       IF (S.NE.SIDENT) GOTO 3470
 424       LPMF=LPMF-6
 425       IF (LPMF.LT.LPML) CALL ERROR(199)
 426       IPMEM(LPMF+1)=ADRES
 427       IPMEM(LPMF+4)=ADRES
 428       IPMEM(LPMF+2)=LN
 429       IPMEM(LPMF+5)=LN
 430       NEXT=STACK(TOP+3)+12
 431       IPMEM(LPMF+3)=IPMEM(NEXT)
 432       IPMEM(NEXT)=LPMF+1
 433       IPMEM(LPMF+6)=IPMEM(NEXT+1)
 434       IPMEM(NEXT+1)=LPMF+4
 435       CALL SCAN
 436       IF (S.EQ.SEMICOL) GOTO 30
 437       IF (S.NE.SCOMA) GOTO 3460
 438       GOTO 365
 439 C                                       HANDLER ENCOUNTERED
 440 380   NEXT=STACK(TOP+3)
 441 C                                       PROTOTYPE ADDRESS IS SAVED
 442       IF (IPMEM(NEXT-1).NE.0) CALL MARK(STACK(TOP+4),STACK(TOP+5))
 443       CALL SLAD(4,11,4)
 444       NEXT=13
 445       RETURN
 446 C                                       CALL E13 TO ANALYSE THE HANDLER
 447 400   NEXT=STACK(TOP+3)
 448       IF (IPMEM(NEXT-1).NE.0) CALL FIND(STACK(TOP+4),STACK(TOP+5))
 449       CALL SCAN
 450 C                                       SKIP THE SEQUENCE "END HANDLERS(;)"
 451 C                                       END HANDLERS (;)
 452       IF (S.EQ.SHANDL) CALL SCAN
 453       IF (S.EQ.SEMICOL) CALL SCAN
 454       GOTO 203
 455       END
 456
 457       SUBROUTINE E12
 458       IMPLICIT INTEGER (A-Z)
 459 C
 460 C  RECOGNIZES BOOLEAN EXPRESSIONS BUILT UP OF CONSTANTS
 461 C
 462 C  LOCAL VARIABLES:
 463 C     STACK(TOP+3) - INCLUDES 1 WHEN "AND" IS TO BE WRITTEN
 464 C     STACK(TOP+4) - ........ 1 .... "OR"  .. .. .. .......
 465 C     STACK(TOP+5) - ........ 1 .... "NOT" .. .. .. .......
 466 C     STACK(TOP+6) - INCLUDES RELATION CODE (SOMETIMES)
 467 C
 468       COMMON /BLANK/
 469      $   C0M(4),
 470      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 471      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 472      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 473      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 474      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 475      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 476      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 477      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 478      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 479      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 480      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 481      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 482      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 483      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 484      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 485      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 486      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 487      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 488
 489       common /BLANK/
 490      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 491      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 492      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 493      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 494      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 495      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 496      N   COM(132),
 497      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 498      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 499      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 500      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 501      $   scaner(8735)
 502 cdsw $   SCANER(3735),
 503       common /BLANK/
 504      Z   TOP,      IN,       NEXT,     STACK(500),
 505      *   RESZTA(3652)
 506
 507       GOTO (10,20,30),IN
 508 10    STACK(TOP+3)=0
 509       STACK(TOP+4)=0
 510       STACK(TOP+5)=0
 511 80    IF (S.NE.SNOT) GOTO 100
 512 C                                  NOT OCCURRED
 513       STACK(TOP+5)=1
 514 85    CALL SCAN
 515 C                                  MAIN LOOP
 516 100   IF (S.EQ.STRUE) GOTO 130
 517 C                                  THERE SHOULD BE AN IDENTIFIER
 518       CALL SLAD(4,12,2)
 519       NEXT=7
 520       RETURN
 521 C                                  CALL E7 - TO ANALYSE ARITHEXPRESSION
 522 20    IF (S.NE.SRELAT) GOTO 200
 523 C                                  '=' OCCURRED (OR SOMETHING ALIKE)
 524 C                                  IT SHOULD BE STORED IN STACK (TOP+6)
 525 115   STACK(TOP+6)=ADRES
 526       CALL SCAN
 527       CALL SLAD(4,12,3)
 528       NEXT=7
 529       RETURN
 530 C                                  ARTITHEXPRESSION CALLED AGAIN
 531 30    CALL OUTPUT(WOPERAT,STACK(TOP+6))
 532       GOTO 200
 533 C                                  LOGICAL CONSTANT
 534 130   CALL OUTPUT(WCNSTB,-1)
 535       CALL OUTPUT(1-ADRES,-1)
 536 C                                  END OF MAIN LOOP
 537 195   CALL SCAN
 538 200   IF (STACK(TOP+5).EQ.0) GOTO 205
 539       CALL OUTPUT(WNOT,-1)
 540       STACK(TOP+5)=0
 541 205   IF (STACK(TOP+3).EQ.0) GOTO 210
 542       CALL OUTPUT(WAND,-1)
 543       STACK(TOP+3)=0
 544 210   IF (S.NE.SAND) GOTO 220
 545       STACK(TOP+3)=1
 546       CALL SCAN
 547       GOTO 80
 548 220   IF (STACK(TOP+4).EQ.0) GOTO 230
 549       CALL OUTPUT(WOR,-1)
 550       STACK(TOP+4)=0
 551 230   IF (S.NE.SOR) GOTO 1000
 552       STACK(TOP+4)=1
 553       CALL SCAN
 554       GOTO 80
 555 1000  NEXT=0
 556       RETURN
 557       END
 558
 559       SUBROUTINE E13
 560       IMPLICIT INTEGER (A-Z)
 561 C  RECOGNIZES HANDLER, BUILDS UP ITS PROTOTYPE
 562 C  LOKAL VARIABLES:
 563 C    STACK(TOP+3) - END-OF-CODE LABEL
 564 C    STACK(TOP+4) - HANDLER PROTOTYPE ADDRESS
 565 C    STACK(TOP+5) - INCLUDES 1 IF "OTHERS" OCCURRED
 566 C    STACK(TOP+6) - PROTOTYPE NUMBER
 567 C  THE FOLLOWING BLANK-COMMON VARIABLES ARE USED AS LOCAL ONES:
 568 C    NRCHAR  - HEAD OF THE CREATED LIST OF NAMES
 569 C    NRCOR
 570 C    NRRE
 571 C    NRBLUS
 572 C
 573 C----------------------------------------------------------------------
 574 C  HANDLER PROTOTYPE:
 575 C
 576 C  ----+-------------------
 577 C   -5 ! NOT USED
 578 C  ----+-------------------
 579 C   -4 ! NOT USED
 580 C  ----+-------------------
 581 C   -3 ! SCRATCH FILE CODE RECORD NUMBER
 582 C  ----+-------------------
 583 C   -2 ! NUMBER OF WORD IN THE CODE RECORD
 584 C  ----+-------------------
 585 C   -1 ! NOT USED
 586 C  ----+-------------------
 587 C    0 ! KIND = 8
 588 C  ----+-------------------
 589 C   +1 ! SL - NUMBER IN ISDICT
 590 C  ----+-------------------
 591 C   +2 ! NOT USED
 592 C  ----+-------------------
 593 C   +3 ! NOT USED
 594 C  ----+-------------------
 595 C   +4 ! NOT USED
 596 C  ----+-------------------
 597 C   +5 ! NOT USED
 598 C  ----+-------------------
 599 C   +6 ! SUBBLOCK LIST
 600 C  ----+-------------------
 601 C   +7 ! NOT USED
 602 C  ----+-------------------
 603 C   +8 ! NOT USED
 604 C  ----+-------------------
 605 C   +9 ! SOURCE TEXT LINE NUMBER
 606 C  ----+-------------------
 607 C  +10 ! LIST OF NAMES
 608 C  ----+-------------------
 609 C
 610 C  NAME LIST ITEM:
 611 C
 612 C  ----+-------------------
 613 C    0 ! NAME
 614 C  ----+-------------------
 615 C   +1 ! NEXT ITEM POINTER
 616 C  ----+-------------------
 617 C
 618 C  NOTE ! EMPTY LIST OF NAMES CORRESPONDS TO THE PROTOTYPE OF A HANDLER
 619 C         FOR "OTHERS"
 620 C
 621       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
 622      X                POSIT,RECNR,NEKST
 623       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
 624       COMMON /BLANK/
 625      $   C0M(4),
 626      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 627      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 628      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 629      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 630      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 631      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 632      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 633      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 634      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 635      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 636      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 637      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 638      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 639      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 640      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 641      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 642      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 643      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 644
 645       common /BLANK/
 646      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 647      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 648      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 649      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 650      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 651      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 652      N   COM(132),
 653      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 654      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 655      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 656      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 657      $   scaner(8735)
 658 cdsw $   SCANER(3735),
 659       common /BLANK/
 660      Z   TOP,      IN,       NEXT,     STACK(500),
 661      *   RESZTA(3652)
 662
 663       DIMENSION IPMEM(1000)
 664       EQUIVALENCE (IPMEM(1),SCANER(1))
 665 cdsw  EQUIVALENCE (AUX,SCANER(3698))
 666       EQUIVALENCE (AUX,SCANER(8698))
 667       EQUIVALENCE (WSTART,WUNLOCK)
 668       DATA SOTHRS/57/
 669
 670       GOTO (10,20),IN
 671 10    NRCHAR=0
 672       STACK(TOP+5)=0
 673       CALL SCAN
 674       IF (S.EQ.SWHEN) GOTO 100
 675       IF (S.EQ.SOTHRS) GOTO 200
 676       CALL ERROR(132)
 677 90    NEXT=0
 678       RETURN
 679 C                                       IS THERE AN IDENTIFIER?
 680 100   CALL SCAN
 681       IF (S.EQ.SIDENT) GOTO 110
 682       CALL ERROR(108)
 683       GOTO 90
 684 C                                       THERE IS
 685 110   LPMF=LPMF-2
 686       IF (LPMF.LT.LPML) CALL ERROR(199)
 687 C                                       CREATE AN ENTRY TO THE NAME LIST
 688       IPMEM(LPMF+2)=NRCHAR
 689       NRCHAR=LPMF+1
 690       IPMEM(NRCHAR)=ADRES
 691       CALL SCAN
 692 C                                       END OF LIST?
 693       IF (S.EQ.SCOLON) GOTO 118
 694 C                                       CONTINUATION?
 695       IF (S.EQ.SCOMA) GOTO 100
 696 C                                       NONE OF ABOVE - ERROR
 697       CALL ERROR(118)
 698       GOTO 90
 699 118   CALL SCAN
 700 120   LPMF=LPMF-17
 701       IF (LPMF.LT.LPML) CALL ERROR(199)
 702 C                                       SLOT FOR THE PROTOTYPE AND HANDLER
 703 C                                       DESCRIPTION FOR THE SYNTACTIC FATHER
 704       NRCOR=LPMF+7
 705       STACK(TOP+4)=NRCOR
 706       STACK(TOP+6)=ISFIN
 707       IPMEM(ISFIN)=NRCOR
 708       ISFIN=ISFIN-1
 709       IPMEM(NRCOR+ 0)=8
 710       IPMEM(NRCOR+ 9)=LN
 711       IPMEM(NRCOR+10)=NRCHAR
 712 C                                       UPDATE FATHER'S SUBMODULE LIST
 713       NRRE=STACK(TOP)
 714       IPMEM(NRCOR+ 1)=STACK(NRRE+6)
 715       NRBLUS=STACK(NRRE+3)
 716       IPMEM(LPMF+1)=STACK(TOP+6)
 717       IPMEM(LPMF+2)=IPMEM(NRBLUS+6)
 718       IPMEM(NRBLUS+6)=LPMF+1
 719 C                                       PREPARE THE INTERMEDIATE CODE
 720       IPMEM(NRCOR- 2)= POSIT
 721       IPMEM(NRCOR- 3)= RECNR
 722       CALL OUTPUT(WFIRST,LN)
 723       CALL OPTOUT
 724       UNICAL=2
 725       STACK(TOP+3)=1
 726       CALL SLAD(4,13,2)
 727       NEXT=8
 728       STACK(TOP+7)=1
 729       RETURN
 730 C                                       CALL E8 TO ANALYSE STATEMENT-LIST
 731 C                                       PARAMETER = 1
 732 20    CALL OUTPUT(WFIN,STACK(TOP+3))
 733       CALL OUTPUT(LN,-1)
 734       NRCHAR=0
 735       IF (S.EQ.SWHEN) GOTO 100
 736       IF (S.EQ.SOTHRS) GOTO 200
 737       IF (S.EQ.SEND) GOTO 90
 738 C                                       WRONG END OF HANDLER
 739       CALL ERROR(142)
 740       GOTO 90
 741 C                                       OTHERS OCCURRED
 742 200   IF (STACK(TOP+5).NE.0) CALL ERROR(129)
 743       STACK(TOP+5)=1
 744       CALL SCAN
 745       IF (S.EQ.SCOLON) CALL SCAN
 746       GOTO 120
 747       END
 748
 749       INTEGER FUNCTION EXYT(K,L)
 750       IMPLICIT INTEGER (A-Z)
 751       COMMON /BLANK/ com(9037), top, in, next, stack(500), reszta(3652)
 752 C
 753 C  THIS FUNCTION RETURNS THE NUMBER OF THE PERTINENT LABEL
 754 C  DEPENDING ON THE VALUE OF THE SECOND PARAMETER, WE CHOOSE
 755 C  THE STARTING LOOP LABEL /FOR L = 0/ OR THE ENDING ONE /L=1/
 756 C
 757       Z=TOP
 758       A=K
 759       GOTO 2
 760 1     Z=STACK(Z)
 761 2     IF (STACK(Z+1).EQ.8) GOTO 10
 762       IF (STACK(Z+1).EQ.13) GOTO 3
 763       IF (STACK(Z+1).NE.9) GOTO 1
 764 C
 765 C    EXIT IS MADE TO THE END OF THE SYNTACTIC UNIT (E9)
 766 C    OR HANDLER (E13)
 767 C
 768 3     IF (A.GT.1) CALL ERROR(110)
 769       IF (L.EQ.0) CALL ERROR(138)
 770       Z=STACK(Z)
 771       EXYT=STACK(Z+3)
 772       RETURN
 773 C
 774 C    DO . . . OD - TYPE LOOP DETECTED
 775 C
 776 10    IF (STACK(Z+2).EQ.13) GOTO 15
 777       IF (STACK(Z+2).EQ.7)  GOTO 15
 778       IF (STACK(Z+2).NE.25) GOTO 1
 779 15    CONTINUE
 780 C
 781 C    FOR... AND WHILE... ARE ALSO ADMITTED..
 782 C
 783       A=A-1
 784       IF (A.GT.0) GOTO 1
 785 C    JUMP OUT IF THE NUMBER OF LOOPS IS LESS THAN THE NUMBER OF
 786 C    EXITS
 787       Z=STACK(Z)
 788       A=Z+L+3
 789       EXYT=STACK(A)
 790       RETURN
 791       END
 792
 793       SUBROUTINE MARK(A,B)
 794       IMPLICIT INTEGER(A-Z)
 795       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
 796      X                POSIT,RECNR,NEXT
 797 C
 798 C  MARKS THE CURRENT LOCATION OF THE SCRATCH FILE
 799 C  MEANING OF PARAMETERS (EXIT ONLY):
 800 C     A - RECORD NUMBER
 801 C     B - POSITION (WORD NUMBER) IN THE RECORD
 802 C
 803       A=RECNR
 804       B=POSIT
 805       CALL PUT(BUF,BUFOUT)
 806       IF (RECNR.NE.NEXT-1) CALL SEEK(BUF,NEXT)
 807       RECNR=NEXT
 808       NEXT=NEXT+1
 809       POSIT=1
 810       RETURN
 811       END
 812
 813       SUBROUTINE FIND (A,B)
 814       IMPLICIT INTEGER (A-Z)
 815 C
 816 C  THIS PROCEDURE RESETS THE POSITION OF THE SCRATCH FILE ACCORDING TO
 817 C  THE PARAMETERS:                   A - RECORD NUMBER
 818 C                                    B - WORD NUMBER
 819 C
 820       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
 821      X                POSIT,RECNR,NEXT
 822       CALL PUT(BUF,BUFOUT)
 823       CALL SEEK(BUF,A)
 824       CALL GET(BUF,BUFOUT)
 825       CALL SEEK(BUF,A)
 826       RECNR=A
 827       POSIT=B
 828       RETURN
 829       END
 830
 831       SUBROUTINE OPTOUT
 832       IMPLICIT INTEGER(A-Z)
 833 C  WRITES TO THE INTERMEDIATE CODE INFORMATION ABOUT ALL OPTIONS
 834 C  (WORD C0M(2)) WITHOUT L-OPTION. CLEARS AUX.
 835       COMMON /BLANK/ c0m(4), blank0(121), wopt, blank1(8873), aux
 836
 837       DO 100 I=2,8
 838       CALL OUTPUT(WOPT,I*(-1+2*IAND(1,ISHFT(C0M(2),2-I))))
 839 100   CONTINUE
 840       AUX=0
 841       RETURN
 842       END
 843
 844       SUBROUTINE SELOPT
 845       IMPLICIT INTEGER (A-Z)
 846 C  WRITES TO THE INTERMEDIATE CODE INFORMATIONS ABOUT ALL OPTIONS FOR WHICH
 847 C  THE CORRESPONDING BITS IN WORD AUX ARE SET.
 848 C  CLEARS AUX.
 849       COMMON /BLANK/ C0M(4),BLANK0(121),WOPT,BLANK1(8873),AUX
 850
 851       LOGICAL BTEST
 852       DO 100 I=2,8
 853       IF (BTEST(AUX,I-2))
 854      X CALL OUTPUT(WOPT,I*(-1+2*IAND(1,ISHFT(C0M(2),2-I))))
 855 100   CONTINUE
 856       AUX=0
 857       RETURN
 858       END
 859
 860       SUBROUTINE OUTPUT(A,B)
 861       IMPLICIT INTEGER (A-Z)
 862 C
 863 C   WRITES INTERMEDIATE CODE TO THE SCRATCH FILE
 864 C
 865       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
 866      X                POSIT,RECNR,NEXT
 867       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
 868       IF (B.NE.-1) GOTO 100
 869       BUFOUT(POSIT)=A
 870       IF (POSIT.EQ.255) GOTO 50
 871       POSIT=POSIT+1
 872       RETURN
 873 50    BUFOUT(256)=NEXT
 874       POSIT=1
 875       CALL PUT(BUF,BUFOUT)
 876       IF (RECNR.NE.NEXT-1) CALL SEEK(BUF,NEXT)
 877       RECNR=NEXT
 878       NEXT=NEXT+1
 879       RETURN
 880 100   IF (POSIT.LT.255) GOTO 150
 881       BUFOUT(255)=A
 882       BUFOUT(256)=NEXT
 883       POSIT=2
 884       CALL PUT(BUF,BUFOUT)
 885       IF (RECNR.NE.NEXT-1) CALL SEEK(BUF,NEXT)
 886       RECNR=NEXT
 887       NEXT=NEXT+1
 888       BUFOUT(1)=B
 889       RETURN
 890 150   BUFOUT(POSIT)=A
 891       BUFOUT(POSIT+1)=B
 892       POSIT=POSIT+2
 893       IF (POSIT.EQ.256) GOTO 50
 894       RETURN
 895       END
 896
 897       SUBROUTINE END
 898       IMPLICIT INTEGER (A-Z)
 899       COMMON /BLANK/ COM(278),
 900      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 901      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 902      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 903      X        LOCAL , OWN   , OBJECT,
 904      X        IPMEM(7890)
 905       LOGICAL  INSYS, LOCAL, OWN
 906 C  IPMEM - MAIN MEMORY
 907 C  LPML  - ADDRESS OF THE FIRST -
 908 C  LPMF  - ADDRESS OF THE LAST  - FREE WORD IN IPMEM
 909 C  ISFIN - TOP OF THE PROTOTYPE DICTIONARY STACK
 910 C  LPMEM - DIVISION POINT FOR IPMEM
 911       COMMON /LISTING/ OUTSTR(265)
 912       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
 913       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
 914      X                POSIT,RECNR,NEXT
 915       LOGICAL ERRFLG
 916 CPS      character auxc(4)
 917 CPS      equivalence (auxc(1), aux)
 918 CPS      data aux /-1/
 919       character int2char
 920
 921       IPMEM(ISFIN-1)=LPMF-LPML+1
 922       NATTR=ISFIN-1
 923 10    NATTR=NATTR-1
 924       IF (IPMEM(NATTR).EQ.0) GOTO 10
 925 cdsw  IPMEM(ISFIN)=NATTR-3738
 926       IPMEM(ISFIN)=NATTR-8738
 927       ISFIN=ISFIN+1
 928       LPMEM=LPMEM-1
 929       IRECN=LPML-1
 930       IF (LPMF.EQ.LMEM) CALL ERROR(191)
 931       NATTR=IPMEM(LPMEM)
 932 C  CHECK IF THE PROTOTYPE DICTIONARY INCLUDES ANY ADDRESS
 933 C  OR IF THE FIRST PROTOTYPE IS BUILT CORRECTLY
 934       IF (IPMEM(LPMEM).EQ.0) CALL ERROR(191)
 935       IF (IPMEM(NATTR).EQ.0) CALL ERROR(191)
 936 cdsw  CALL CLOSF(OUTSTR)
 937 cdsw  CALL CLOSF(INSTR)
 938       CALL PUT(BUF,BUFOUT(1))
 939       COM(2)=NEXT
 940       IF (ERRFLG) GOTO 1
 941 cdsw  znacznik konca stringow
 942 cbc   WRITE(15) -1
 943       call ffwrite_ints( 15, -1, 1 )
 944 cbc
 945 1     CONTINUE
 946 c  end of file 16
 947       call ffwrite_char(16, int2char(26))
 948 C --- MPTBUF SEEMS NOT NECESSARY IN THE 'ONE-OVERLAY' VERSION
 949 C     CALL MPTBUF
 950       RETURN
 951       END
 952
 953       SUBROUTINE SLAD(NROFVAR,NR,MIEJSCE)
 954       IMPLICIT INTEGER (A-Z)
 955       COMMON /BLANK/ COM(9037), TOP, IN, NEXT, STACK(500), RESZTA(3652)
 956 C  PREPARES STACK FOR CALL OF ANOTHER PROCEDURE
 957 C  PARAMETERS:
 958 C     NROFVAR - NUMBER OF THE LOCAL VARIABLES ALLOCATED ON THE STACK
 959 C     NR      - NUMBER OF THE CALLING PROCEDURE
 960 C     SLAD    - NUMBER OF THE RETURN POINT
 961       EQUIVALENCE(COM(282),ISFIN)
 962 cdsw  IF (TOP+3748.GT.ISFIN) CALL ERROR(198)
 963       IF (TOP+8748.GT.ISFIN) CALL ERROR(198)
 964 C  CHECK IF THE STACK ISN'T TOO LONG
 965       Z=TOP
 966       TOP=TOP+NROFVAR+3
 967       STACK(TOP)=Z
 968       STACK(TOP+1)=NR
 969       STACK(TOP+2)=MIEJSCE
 970       IN=1
 971       RETURN
 972       END
 973
 974       SUBROUTINE ADDPAR(LHEAD,MFIELD)
 975       IMPLICIT INTEGER (A-Z)
 976 C
 977 C  APPENDS PARAMETERS TO THE CREATED PROTOTYPE
 978 C  PARAMETERS: LHEAD - BEGINNING OF THE PARAMETER LIST
 979 C             MFIELD - ADDRESS OF THE PLACE TO BE CHANGED IN CASE OF
 980 C                      ERRONEOUS LIST
 981 C  MODIFICATION FUNCTION:
 982 C    CONVERT:  [1..10]  ------>  [1,7,5,6,5,6,7,8,10,10]
 983 C  THE FOLLOWING BLANK-COMMON VARIABLES ARE USED:
 984 C    OBJECT  - LAST ELEMENT ON THE PARAMETER LIST (LINK FIELD)
 985 C    KIND    - A LOCAL VARIABLE
 986 C    NRRE    - COUNTS NUMBER OF OCCURRENCES OF ARRAYOF'S
 987 C    NATTR   - KEEPS THE RECOGNIZED TYPE
 988 C    NRCHR   - A LOCAL VARIABLE (LOOP LIMIT)
 989 C    NRCOR   - AS ABOVE
 990 C    NRTEXT  - SAVES THE VALUE OF VARIABLE OBJECT
 991 C    NRPROC  - ADDRESS OF THE PLACE TO BE WVERWRITTEN
 992 C    NBLUS   - ANALYSIS LEVEL         1 - PARAMETER LIST
 993 C                                     2 - SIMPLIFIED LIST
 994 C---------------------------------------------------------------------
 995 C    ITEM OF THE FORMAL PARAMETER LIST:
 996 C
 997 C   0 ! KIND
 998 C  ---+------------------
 999 C -1 ! SOURCE TEXT LINE NUMBER
1000 C +--+------------------
1001 C -2 ! NAME
1002 C +--+------------------
1003 C +3 ! NEXT ITEM INDEX
1004 C REMAINDER FOR VARIABLES    FOR PROCEDURES AND FUNCTIONS
1005 C ---+------------------------------------------------------------
1006 C +4 ! TYPE NUMBER     !  +4 ! FORMAL PARAMETER LIST
1007 C ---+-----------------------+------------------------------------
1008 C +5 ! ARRAYOF COUNT   !  +5 ! TYPE NAME   (KIND = FUNCTION)
1009 C                         ----+------------------------------------
1010 C                         +6 ! NUMBER OF ARRAYOF'S (KIND = FUNCTION)
1011 C   WHERE KIND:
1012 C      3 - PROCEDURE
1013 C      4 - FUNCTION
1014 C      5 - PROCEDURE WITH ERRONEOUS PARAMETER LIST
1015 C      6 - FUNCTION  "      "       "       "
1016 C      7 - TYPE
1017 C      8 - VARIABLE "INPUT"
1018 C      9 - VARIABLE "OUTPUT"
1019 C     10 - VARIABLE "INOUT"
1020 C
1021       DIMENSION CONVERT(10)
1022       COMMON /BLANK/
1023      $   C0M(4),
1024      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
1025      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
1026      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
1027      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
1028      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
1029      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
1030      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
1031      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
1032      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
1033      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
1034      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
1035      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
1036      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
1037      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
1038      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
1039      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
1040      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
1041      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
1042
1043       common /BLANK/
1044      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
1045      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
1046      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
1047      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
1048      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
1049      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
1050      N   COM(132),
1051      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
1052      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
1053      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
1054      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
1055      $   scaner(8735)
1056 cdsw $   SCANER(3735),
1057       common /BLANK/
1058      Z   TOP,      IN,       NEXT,     STACK(500),
1059      *   RESZTA(3652)
1060
1061       DIMENSION IPMEM(7890)
1062       EQUIVALENCE (IPMEM(1),SCANER(1))
1063       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
1064       DATA CONVERT/1,7,5,6,5,6,7,8,10,10/
1065
1066       OBJECT=LHEAD
1067       NBLUS=1
1068 10    CALL SCAN
1069 11    IF (S.EQ.SINPUT) GOTO 100
1070       IF (S.EQ.SIDENT) GOTO 150
1071       IF (S.EQ.STYPE)  GOTO 300
1072       IF (S.EQ.SFUNCT) GOTO 400
1073       IF (S.EQ.SPRCD)  GOTO 500
1074 C  NO KEYWORDS HAVE BEEN FOUND WHICH COULD PROPERLY START THE PARAMETER LIST
1075 C  NOW WE SHOULD FIND A PERTINENT DELIMITER-SYMBOL TO CONTINUE ANALYSIS
1076 C  THE PROTOTYPE IS ALSO TO BE CHANGED
1077       CALL ERROR(107)
1078 C  LOCAL USAGE OF VARIABLES NRCHAR
1079 C  AND NRCOR  (CODE OPTIMIZATION)
1080 80    NRCHAR=MFIELD
1081       NRCOR=IPMEM(NRCHAR)
1082       IPMEM(NRCHAR)=CONVERT(NRCOR)
1083 81    IF (S.LT.25) GOTO 90
1084       IF (S.EQ.SBECOME) GOTO 90
1085       IF (S.EQ.SRIGHT)  GOTO (90,550),NBLUS
1086       IF (S.EQ.SEND)    GOTO 90
1087       IF (S.EQ.SBEGIN)  GOTO 90
1088       IF (S.EQ.SCONS)   GOTO 90
1089       IF (S.EQ.SUNIT)   GOTO 90
1090       IF (S.EQ.STAKEN)  GOTO 90
1091       IF (S.EQ.SCLOSE)  GOTO 90
1092       IF (S.EQ.SEOF)    GOTO 90
1093       IF (S.EQ.SINPUT)  GOTO 100
1094       IF (S.EQ.STYPE)   GOTO 300
1095       IF (S.EQ.SFUNCT)  GOTO (400,600),NBLUS
1096       IF (S.EQ.SPRCD)   GOTO (500,700),NBLUS
1097       IF (S.EQ.SRELAT)  GOTO 90
1098       IF (S.EQ.SAND)    GOTO 90
1099       CALL SCAN
1100       GOTO 81
1101 CPS 85    CALL SCAN
1102 90    RETURN
1103 100   KIND=7+ADRES
1104 C                       KIND INCLUDES 8 - INPUT
1105 C                                     9 - OUTPUT
1106 C                                    10 - INOUT
1107       GOTO 210
1108 150   KIND=8
1109       J=1
1110       GOTO 222
1111 210   J=1
1112 220   CALL SCAN
1113 222   J=J+1
1114       IF (J.GT.132) CALL ERROR(197)
1115       IF (S.EQ.SIDENT) GOTO 225
1116       CALL ERROR(109)
1117 C  ERROR IN SPECIFICATION OF INPUT/OUTPUT-TYPE PARAMETERS
1118 C  THE TYPE OF THE VARIABLES IS UNDEFINED
1119       COM(J)=0
1120       NRRE=0
1121       NATTR=0
1122       GOTO 255
1123 225   COM(J)=ADRES
1124       CALL SCAN
1125       IF (S.EQ.SCOMA) GOTO 220
1126       IF (S.EQ.SCOLON) GOTO 230
1127       CALL ERROR(118)
1128       GOTO 11
1129 230   NRRE=0
1130 240   CALL SCAN
1131       IF (S.NE.SARROF) GOTO 250
1132       NRRE=NRRE+1
1133       GOTO 240
1134 250   NATTR=0
1135       IF (S.EQ.SCOROUT) NATTR=K
1136       IF (S.EQ.SINT)    NATTR=ADRES*8
1137       IF (S.EQ.SIDENT)  NATTR=ADRES
1138       IF (NATTR.EQ.0) CALL ERROR(109)
1139 255   NRCHAR=2
1140       NRCOR=J
1141       DO 260 J=NRCHAR,NRCOR
1142       LPMF=LPMF-6
1143       IF (LPMF.LT.LPML) CALL ERROR(199)
1144       IPMEM(LPMF+1)=KIND
1145       IPMEM(LPMF+2)=LN
1146       IPMEM(LPMF+3)=COM(J)
1147       IPMEM(OBJECT)=LPMF+1
1148       OBJECT=LPMF+4
1149       IPMEM(LPMF+5)=NATTR
1150       IPMEM(LPMF+6)=NRRE
1151 260   CONTINUE
1152       IF (NATTR.EQ.0) GOTO 80
1153       CALL SCAN
1154       IF (S.EQ.SCOMA) GOTO 210
1155       IF (S.EQ.SEMICOL) GOTO (10,541),NBLUS
1156       IF (S.EQ.SRIGHT) GOTO (90,550),NBLUS
1157       CALL ERROR(102)
1158       GOTO (80,545),NBLUS
1159 300   CALL SCAN
1160       IF (S.EQ.SIDENT) GOTO 310
1161       CALL ERROR(109)
1162       GOTO (80,545),NBLUS
1163 310   LPMF=LPMF-4
1164       IF (LPMF.LT.LPML) CALL ERROR(199)
1165       IPMEM(LPMF+1)=7
1166       IPMEM(LPMF+2)=LN
1167       IPMEM(LPMF+3)=ADRES
1168       IPMEM(OBJECT)=LPMF+1
1169       OBJECT=LPMF+4
1170       CALL SCAN
1171       IF (S.EQ.SEMICOL) GOTO (10,541),NBLUS
1172       IF (S.EQ.SRIGHT) GOTO (90,550),NBLUS
1173       IF (S.EQ.SCOMA) GOTO 320
1174       CALL ERROR(107)
1175       GOTO (80,545),NBLUS
1176 320   CALL SCAN
1177       IF (S.EQ.SIDENT) GOTO 310
1178       CALL ERROR(109)
1179       GOTO (80,545),NBLUS
1180 400   KIND=4
1181       GOTO 510
1182 500   KIND=3
1183 510   CALL SCAN
1184       IF (S.EQ.SIDENT) GOTO 520
1185       CALL ERROR(109)
1186       GOTO 80
1187 520   LPMF=LPMF+2*KIND-15
1188       IF (LPMF.LT.LPML) CALL ERROR(199)
1189       IPMEM(LPMF+1)=KIND
1190       IPMEM(LPMF+2)=LN
1191       IPMEM(LPMF+3)=ADRES
1192       IPMEM(OBJECT)=LPMF+1
1193       OBJECT=LPMF+4
1194       CALL SCAN
1195       NRPROC=LPMF
1196 C  THE POINTER TO THE CURRENT ELEMENT OF THE PARAMETER LIST IS SAVED
1197       IF (S.EQ.SLEFT) GOTO 540
1198       IF (KIND.EQ.4) GOTO 530
1199       IF (S.EQ.SEMICOL) GOTO 10
1200       IF (S.EQ.SRIGHT) RETURN
1201       CALL ERROR(107)
1202       GOTO 80
1203 530   NRRE=0
1204       IF (S.EQ.SCOLON) GOTO 531
1205       CALL ERROR(118)
1206       GOTO 535
1207 531   CALL SCAN
1208       IF (S.NE.SARROF) GOTO 535
1209       NRRE=NRRE+1
1210       GOTO 531
1211 535   NATTR=0
1212       IF (S.EQ.SCOROUT) NATTR=K
1213       IF (S.EQ.SINT)    NATTR=ADRES*8
1214       IF (S.EQ.SIDENT)  NATTR=ADRES
1215       IPMEM(NRPROC+6)=NATTR
1216       IPMEM(NRPROC+7)=NRRE
1217       IF (NATTR.EQ.0) GOTO 537
1218       CALL SCAN
1219       GOTO 538
1220 537   CALL ERROR(109)
1221       GOTO 80
1222 538   IF (S.EQ.SRIGHT) RETURN
1223       IF (S.EQ.SEMICOL) GOTO 10
1224       CALL ERROR(107)
1225       GOTO 80
1226 540   NRTEXT=OBJECT
1227       OBJECT=OBJECT+1
1228       NBLUS=2
1229 541   CALL SCAN
1230       IF (S.EQ.SINPUT)  GOTO 100
1231       IF (S.EQ.SIDENT)  GOTO 150
1232       IF (S.EQ.STYPE)   GOTO 300
1233       IF (S.EQ.SFUNCT)  GOTO 600
1234       IF (S.EQ.SPRCD)   GOTO 700
1235       IF (S.EQ.SRIGHT)  GOTO 550
1236       CALL ERROR(107)
1237 545   IF (IPMEM(NRPROC+1).LT.5) IPMEM(NRPROC+1)=IPMEM(NRPROC+1)+2
1238 C   ERRONEOUS PARAMETER LIST. WE SHOULD FIND A SYMBOL WHICH WOULD
1239 C   ALLOW FOR A FURTHER (REASONABLE) ANALYSIS OF THE SOURCE TEXT.
1240 C   THE SEARCHING IS COMMON FOR BOTH PARAMETER LEVELS.
1241       GOTO 80
1242 550   NBLUS=1
1243       OBJECT=NRTEXT
1244       CALL SCAN
1245       IF (IPMEM(OBJECT-3).EQ.4) GOTO 530
1246       IF (S.EQ.SEMICOL) GOTO 10
1247       IF (S.EQ.SRIGHT) RETURN
1248       CALL ERROR(107)
1249       GOTO 80
1250 600   KIND=4
1251       GOTO 710
1252 700   KIND=3
1253 710   CALL SCAN
1254       IF (S.EQ.SIDENT) GOTO 720
1255       CALL ERROR(109)
1256       GOTO 545
1257 720   LPMF=LPMF-4
1258       IF (LPMF.LT.LPML) CALL ERROR(199)
1259       IPMEM(LPMF+1)=KIND
1260       IPMEM(LPMF+2)=LN
1261       IPMEM(LPMF+3)=ADRES
1262       IPMEM(OBJECT)=LPMF+1
1263       OBJECT=LPMF+4
1264       CALL SCAN
1265       IF (S.EQ.SRIGHT) GOTO 550
1266       IF (S.EQ.SEMICOL) GOTO 541
1267       CALL ERROR(107)
1268       GOTO 545
1269       END
1270
1271       SUBROUTINE ADDVAR(SKAD,ILE)
1272       IMPLICIT INTEGER (A-Z)
1273 C
1274 C  APPENDS THE LIST OF VARIABLES TO THE LIST IN THE PROTOTYPE
1275 C  RECOGNIZES TYPES OF VARIABLES
1276 C  STACK(TOP+3) - PROTOTYPE ADDRESS
1277 C
1278 C  ILE  - LENGTH OF THE LIST OF VARIABLES
1279 C  SKAD - BEGINNING OF THE LIST - VARIABLES ARE LOCATED IN CONSECUTIVE
1280 C         WORDS
1281 C
1282 C--------------------------------------------------------------------
1283 C  VARIABLE LIST ITEM:
1284 C  0 ! NAME OF THE VARIABLE
1285 C ---+------------------------
1286 C +1 ! DECLARATION LINE NUMBER IN THE SOURCE TEXT
1287 C ---+------------------------
1288 C +2 ! TYPE NAME
1289 C ---+------------------------
1290 C +3 ! NUMBER OF ARRAYOF'S
1291 C ---+------------------------
1292 C +4 ! NEXT ITEM POINTER
1293 C
1294       DIMENSION SKAD(2)
1295       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
1296       COMMON /BLANK/
1297      $   C0M(4),
1298      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
1299      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
1300      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
1301      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
1302      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
1303      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
1304      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
1305      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
1306      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
1307      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
1308      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
1309      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
1310      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
1311      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
1312      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
1313      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
1314      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
1315      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
1316
1317       common /BLANK/
1318      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
1319      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
1320      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
1321      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
1322      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
1323      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
1324      N   COM(132),
1325      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
1326      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
1327      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
1328      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
1329      $   scaner(8735)
1330 cdsw $   SCANER(3735),
1331       common /BLANK/
1332      Z   TOP,      IN,       NEXT,     STACK(500),
1333      *   RESZTA(3652)
1334
1335       DIMENSION  IPMEM(7890)
1336       EQUIVALENCE (SCANER(1),IPMEM(1))
1337       EQUIVALENCE (SOUTPUT,SEMAPH)
1338
1339 C  VARIABLE ARR COUNTS THE NUMBER OF ARRAYOF'S ENCOUNTERED
1340       ARR=0
1341       IF (S.NE.SARROF) GOTO 2
1342 1     ARR=ARR+1
1343       CALL SCAN
1344       IF (S.EQ.SARROF) GOTO 1
1345 C  TYPE OF THE VARIABLE IS RECOGNIZED
1346 2     IF (S.EQ.SINT) GOTO 10
1347       IF (S.EQ.SCOROUT) GOTO 8
1348       IF (S.EQ.SIDENT) GOTO 6
1349       IF (S.EQ.SEMAPH) GOTO 4
1350 C  ERROR IN DECLARATION - UNIVERSAL TYPE (0) IS ASSUMED
1351       ADRES=0
1352       CALL ERROR(109)
1353 4     KIND=32
1354       IF (ARR.EQ.0) GOTO 90
1355       ARR=0
1356       CALL ERROR(141)
1357       GOTO 90
1358 6     KIND=ADRES
1359       GOTO 90
1360 8     KIND=K
1361 C   COROUTINE / PROCESS ARE TREATED AS IDENTIFIERS
1362 C   VARIABLE K INCLUDES HASH TABLE ADDRESS
1363       GOTO 90
1364 10    KIND=ADRES*8
1365 90    CALL SCAN
1366 C  THE VARIABLE LIST IS COPIED INTO THE CREATED VARIABLE DESCRIPTIONS
1367       DO 100 I=1,ILE
1368       LPMF=LPMF-5
1369       IF (LPMF.LT.LPML) CALL ERROR(199)
1370 C  ERROR(199) - PARSER TABLE OVERFLOW
1371       IPMEM(LPMF+1)=SKAD(I)
1372       IPMEM(LPMF+2)=LN
1373       IPMEM(LPMF+3)=KIND
1374       IPMEM(LPMF+4)=ARR
1375 C  THE NEW ELEMENT IS APPENDED TO THE VARIABLE LIST
1376 C  NRRE - SCRATCH - BEGINNING OF THE LIST (TAKEN FROM THE PROTOTYPE)
1377       NRRE=STACK(TOP+3)+3
1378       IPMEM(LPMF+5)=IPMEM(NRRE)
1379       IPMEM(NRRE)=LPMF+1
1380 100   CONTINUE
1381       RETURN
1382       END
1383
1384
1385       SUBROUTINE OVERF(K)
1386       IMPLICIT INTEGER (A-Z)
1387       COMMON /LISTING/ OUTSTR(265)
1388       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
1389       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
1390      X                POSIT,RECNR,NEXT
1391 1     IF (BUFOR(1).EQ.2) GOTO 2
1392       CALL READIN
1393       GOTO 1
1394 2     CALL APARS
1395 cdsw   CALL CLOSF(OUTSTR)
1396 cdsw   CALL CLOSF(INSTR)
1397       CALL MDROP(K)
1398       RETURN
1399       END
1400
1401       SUBROUTINE OPTSET
1402       IMPLICIT INTEGER (A-Z)
1403 C  SETS UP THE OPTION WORD - C0M(2)
1404 CJF  CALLED WHENEVER '(*[' IS ENCOUNTERED
1405 C  CALLED WHENEVER '(*$' IS ENCOUNTERED
1406 CJF  VARIABLE LP IS ASSUMED TO POINT TO THE FIRST CHARACTER FOLLOWING '['
1407 C  VARIABLE LP IS ASSUMED TO POINT TO THE FIRST CHARACTER FOLLOWING '$'
1408 C  IT IS ADVANCED BY OPTSET
1409 C
1410 C  MEANING OF THE PARTICULAR BITS IC C0M(2)
1411 C    BIT(S)   MEANING
1412 C     0   -   OPTION MEMBER-CONTROL   ( 1 - ON, 0 - OFF )              M
1413 C     1   -   OPTION OPTIMIZATION                                      O
1414 C     2   -   OPTION INDEX-CONTROL                                     I
1415 C     3   -   OPTION TYPE-CONTROL                                      T
1416 C     4   -   OPTION TRACE-CONTROL                                     D
1417 C     5   -   OPTION CASE-CONTROL     (NOT USED IN THE L-COMPILER)     C
1418 C     6   -   OPTION FAST CASE                     "                   F
1419 C     7-12    NOT USED
1420 C    13   -   OPTION FOR T.SZCZEPANEK              "                   S
1421 C    14   -   OPTION PSEUDO-PARALLEL               "                   P
1422 C    15   -   OPTION LISTING                                           L
1423 C
1424 C  NOTE:  PARTICULAR BITS IN AUX (0-12) CORRESPOND TO THE CHANGES IN
1425 C         C0M(2). THEY ARE SET UP WHEN THE CORRESPONDING OPTIONS ARE SELECTED
1426 C
1427 C  NOTE:  THE NUMBERS OF OPTIONS WRITTEN TO THE INTERMEDIATE CODE RESULT
1428 C         FROM ADDING 2 TO THE CORRESPONDING BIT NUMBERS.
1429 C
1430 C  WORDS C0M(3) AND C0M(4) ARE USED TO FORCE EXTERNAL SETTING OF OPTIONS.
1431 C  EXTERNAL SETTING (VIA RESPONSE TO THE COMPILER PROMPT) TAKES PRECEDENCE.
1432 C  OPTION 'P' (14) CAN BE SET ONLY EXTERNALLY.
1433 C  INITIAL VALUES:
1434 C    C0M(2) - X'802F'
1435 C    C0M(3) - X'0000'
1436 C    COM(4) - X'FFFF'
1437 C
1438       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
1439      X                POSIT,RECNR,NEKST
1440       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
1441       COMMON /BLANK/ C0M(4),BLANK(8995),AUX,BLANK1(4192)
1442
1443 C  RECOGNIZE THE OPTION
1444 cdsw ------------ changed to lower-case or upper case letters -----
1445 10    continue
1446       x = ord(bufor(lp))
1447       if(x.ne.ord(ichar('l'))) goto 100
1448 cdsw10    IF (BUFOR(LP).NE.ICHAR('L')) GOTO 100
1449 cdsw -------------------------------------------
1450 C  'L' RECOGNIZED
1451       IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 50
1452       IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 30
1453       CALL ERROR(135)
1454 30    C0M(2)=IBSET(C0M(2),15)
1455       GOTO 80
1456 50    C0M(2)=IBCLR(C0M(2),15)
1457 C  MASK UP THE OPTIONS WHICH HAVE BEEN DECLARED EXTERNALLY
1458 cdsw&bc  80    C0M(2)=IOR(C0M(3),IAND(C0M(4),C0M(2)))
1459 80    continue
1460 c
1461       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1462       LP=LP+3
1463       GOTO 10
1464 cdsw ---------------- changed -------------
1465 100   if(x.ne.ord(ichar('m')))goto 200
1466 cdsw100   IF (BUFOR(LP).NE.ICHAR('M')) GOTO 200
1467 cdsw--------------------------------------------
1468 C  'M' RECOGNIZED - MEMBER-CONTROL
1469       IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 150
1470       IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 130
1471       CALL ERROR(135)
1472 130   C0M(2)=IBSET(C0M(2),0)
1473       GOTO 180
1474 150   C0M(2)=IBCLR(C0M(2),0)
1475 180   AUX=IBSET(AUX,0)
1476       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1477       LP=LP+3
1478       GOTO 10
1479 cdsw ---------------- changed ---------------
1480 200   if(x.ne.ord(ichar('o'))) go to 300
1481 cdsw200   IF (BUFOR(LP).NE.ICHAR('O')) GOTO 300
1482 cdsw -----------------------------------------
1483 C  'O' RECOGNIZED - OPTIMIZATION
1484       IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 250
1485       IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 230
1486       CALL ERROR(135)
1487 230   C0M(2)=IBSET(C0M(2),1)
1488       GOTO 280
1489 250   C0M(2)=IBCLR(C0M(2),1)
1490 280   AUX=IBSET(AUX,1)
1491       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1492       LP=LP+3
1493       GOTO 10
1494 cdsw ------------------- changed ---------
1495 300    if(x.ne.ord(ichar('i'))) go to 400
1496 cdsw300   IF (BUFOR(LP).NE.ICHAR('I')) GOTO 400
1497 cdsw ----------------------------------------
1498 C  'I' RECOGNIZED - INDEX-CONTROL
1499       IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 350
1500       IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 330
1501       CALL ERROR(135)
1502 330   C0M(2)=IBSET(C0M(2),2)
1503       GOTO 380
1504 350   C0M(2)=IBCLR(C0M(2),2)
1505 380   AUX=IBSET(AUX,2)
1506       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1507       LP=LP+3
1508       GOTO 10
1509 cdsw ------------ changed -----------------
1510 400   if(x.ne.ord(ichar('t'))) go to 500
1511 cdsw400   IF (BUFOR(LP).NE.ICHAR('T')) GOTO 500
1512 cdsw -------------------------------------
1513 C  'T' RECOGNIZED - TYPE-CONTROL
1514       IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 450
1515       IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 430
1516       CALL ERROR(135)
1517 430   C0M(2)=IBSET(C0M(2),3)
1518       GOTO 480
1519 450   C0M(2)=IBCLR(C0M(2),3)
1520 480   AUX=IBSET(AUX,3)
1521       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1522       LP=LP+3
1523       GOTO 10
1524 cdsw ------------- changed ----------------
1525 500   if(x.ne.ord(ichar('d'))) go to 600
1526 cdsw500   IF (BUFOR(LP).NE.ICHAR('D')) GOTO 600
1527 cdsw ---------------------------------------
1528 C  'D' RECOGNIZED - TRACE-CONTROL
1529       C0M(2)=IBCLR(C0M(2),4)
1530       IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 550
1531       IF (BUFOR(LP+1).NE.ICHAR('+')) CALL ERROR(135)
1532 530   C0M(2)=IBSET(C0M(2),4)
1533 550   AUX=IBSET(AUX,4)
1534       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1535       LP=LP+3
1536       GOTO 10
1537 cdsw --------------- changed ----------------------
1538 600   if(x.ne.ord(ichar('c'))) go to 700
1539 cdsw600   IF (BUFOR(LP).NE.ICHAR('C')) GOTO 700
1540 cdsw ----------------------------------------------
1541 C  'C' RECOGNIZED - CASE-CONTROL
1542       C0M(2)=IBSET(C0M(2),5)
1543       IF (BUFOR(LP+1).EQ.ICHAR('-')) GOTO 630
1544       IF (BUFOR(LP+1).NE.ICHAR('+')) CALL ERROR(135)
1545       GOTO 650
1546 630   C0M(2)=IBCLR(C0M(2),5)
1547 650   AUX=IBSET(AUX,5)
1548       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1549       LP=LP+3
1550       GOTO 10
1551 cdsw --------- changed ------------------------
1552 700   if(x.ne.ord(ichar('f'))) go to 800
1553 cdsw700   IF (BUFOR(LP).NE.ICHAR('F')) GOTO 800
1554 cdsw -----------------------------------------
1555 C  'F' RECOGNIZED - FAST CASE
1556       C0M(2)=IBCLR(C0M(2),6)
1557       IF (BUFOR(LP+1).EQ.ICHAR('+')) GOTO 730
1558       IF (BUFOR(LP+1).NE.ICHAR('-')) CALL ERROR(135)
1559       GOTO 650
1560 730   C0M(2)=IBSET(C0M(2),6)
1561 750   AUX=IBSET(AUX,6)
1562       IF (BUFOR(LP+2).NE.ICHAR(',')) GOTO 9999
1563       LP=LP+3
1564       GOTO 10
1565 800   LP=LP-3
1566 C  NO VALID OPTION HAS BEEN RECOGNIZED
1567       CALL ERROR(135)
1568 cdsw&bc  9999  C0M(2)=IOR(C0M(3),IAND(C0M(4),C0M(2)))
1569 9999  continue
1570 c
1571       RETURN
1572       END
1573