sources/pass1/wan1.ff

   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
  17       SUBROUTINE WAN
  18       IMPLICIT INTEGER (A-Z)
  19       LOGICAL  INSYS,  OWN
  20       COMMON /BLANK/ COM(278),
  21      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
  22      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
  23      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
  24      X        LOCAL , OWN   , OBJECT,
  25      X        IPMEM(5000)
  26 C
  27 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
  28 C             LMEM   - (=32000) ROZMIAR CALEJ PAMIECI GLOWNEJ
  29 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
  30 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
  31 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
  32 C
  33 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
  34 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
  35 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
  36 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
  37 C
  38 C     IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
  39 C             NRINT  - IDENTYFIKATOR PROTOTYPU  INTEGER
  40 C             NRRE   -                          REAL
  41 C             NRBOOL -                          BOOLEAN
  42 C             NRCHR  -                          CHARACTER
  43 C             NRCOR  -                          COROUTINE
  44 C             NRPROC -                          PROCESS
  45 C             NRTEXT -                          STRING (TEXT)
  46 C             NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
  47 C             NATTR  - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
  48 C             NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
  49 C                      REFERENCYJNY)
  50 C             NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
  51 C             NBLUS  -               BLOKU GLOWNEGO UZYTKOWNIKA
  52 C
  53 C             INSYS  - FLAGA SPOSOBU REZERWACJI (PRZEZ  MGETM) PAMIECI
  54 C                      W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
  55 C                      MOWEJ
  56 C             LOCAL  - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
  57 C         BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
  58 C             OWN    - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
  59 C                      POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
  60 C             OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
  61 C                     SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
  62 C
  63
  64 cdeb ----------- added ----------------------
  65 c  new common blockfor the debugger
  66       common /debug/ deb,breakt(500),brnr,maxbr
  67       logical deb
  68 c  deb = true - compilation with the debugger
  69 c  breakt - array of static break points
  70 c  brnr - index in breakt
  71 c  maxbr - maximal number of static break points
  72 cdeb ----------------------------------------
  73
  74       COMMON /MJLMSG/IERC,MSG
  75
  76       common /option/opt
  77       integer*4 msg
  78
  79 cdsw  DATA IDENT /4HWAN /
  80
  81 cdsw  MSG = IDENT
  82       msg = 'wan '
  83       IERC = 0
  84       CALL DATA1
  85 cdeb
  86       if(deb) call inbr
  87 cdeb
  88       CALL E0
  89       opt = com(2)
  90       CALL END
  91 cdeb
  92       if(deb) call endbr
  93 cdeb
  94       CALL MESS
  95       CALL IT1
  96       END
  97
  98       SUBROUTINE DATA1
  99       IMPLICIT INTEGER (A-Z)
 100       character jfname(72)
 101       common /jf/jfname(72),jf
 102       integer*2 bigbuf
 103       common /combuf/ ind, length, bigbuf(16000)
 104 C
 105 C  OPENS FILES
 106 C
 107       LOGICAL  ERRFLG
 108       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
 109      X                POSIT,RECNR,NEXT
 110       COMMON /LISTING/ OUTSTR(265)
 111       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
 112       COMMON /BLANK/
 113      $   C0M(4),
 114      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 115      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 116      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 117      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 118      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 119      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 120      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 121      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 122      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 123      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 124      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 125      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 126      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 127      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 128      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 129      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 130      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 131      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 132
 133       common /BLANK/
 134      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 135      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 136      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 137      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 138      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 139      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 140      N   COM(132),
 141      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 142      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 143      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 144      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 145      S   HASH(8000), M,        NAME(10), NLAST,    NL,
 146      T   KEYS(200),
 147      U   TRANS1(13,13),      TRANS2(13,13),      B0,       B(70),
 148      V   SKOK0,    SKOK(70), KK,       MM,       STAN,     STAN1,
 149      W   AUX,      K1,       SY,       SY1,      NU,       EXP,
 150      X   SIGN,     INTPART,  FRAC,     OKEY,     FRACT,    NB,
 151      Y   TL,       BYTE,     TEXT(20),
 152      Z   TOP,      IN,       NEKST,    STACK(500)
 153
 154       common /BLANK/
 155      *   RESZTA(3652)
 156
 157 cdsw   error !!!!
 158       real fract, nu
 159 c
 160       logical btest
 161       character int2char
 162
 163 cdeb ----------- added ----------------------
 164 c  new common blockfor the debugger
 165       common /debug/ deb,breakt(500),brnr,maxbr
 166       logical deb
 167 c  deb = true - compilation with the debugger
 168 c  breakt - array of static break points
 169 c  brnr - index in breakt
 170 c  maxbr - maximal number of static break points
 171
 172 cdeb ----------------------------------------
 173
 174
 175       DIMENSION W(63)
 176       EQUIVALENCE (W(1),WAND)
 177
 178 cdsw   kod spacji ascii
 179       data data1hex /x'2020'/
 180
 181
 182 cdeb
 183 c   nadanie wartosci zmiennej deb - czy zapalona opcja S
 184       deb = .false.
 185       if(btest(c0m(2),13)) deb = .true.
 186 cdeb
 187
 188       DO 10 I=1,63
 189 10    W(I)=I
 190       UNICAL = 3
 191 C ---
 192 c   unit 16 - roboczy listing (sequential )
 193       call ffcrtmp(16)
 194 C --- WRITE LISTING OPTION FLAG
 195       call ffwrhex(16, c0m(2))
 196 C ---
 197       ERRFLG = .FALSE.
 198
 199 cdsw *********** new file **************
 200 c  unit 18 - roboczy,sekwencyjny do kodu posredniego
 201       call ffcrtmp(18)
 202
 203 c ------   unit 14 (buf) - kod posredni (direct)
 204       CALL OPENF(BUF,14)
 205       POSIT=1
 206 cdsw  RECNR=12
 207 cdsw  NEXT=13
 208       recnr = 32
 209       next = 33
 210       call seek(buf,recnr)
 211 C     DATA BUFOR,LN,LP,MAX /85*4Z2020,0,81,81/
 212       LN=0
 213       LP=81
 214       MAX=81
 215
 216       do 9997 jf=1,70
 217       if (jfname(jf).eq.'.') go to 9998
 218       if (jfname(jf).eq.' ') goto 9996
 219 9997  continue
 220 9996  if(jf+4.gt.70) goto 9991
 221       jfname(jf) = '.'
 222       jfname(jf+1) = 'l'
 223       jfname(jf+2) = 'o'
 224       jfname(jf+3) = 'g'
 225 9998  continue
 226       jfname(jf+4) = int2char(0)
 227 9991  jfname(70) = int2char(0)
 228 c   unit 17 - input (sequential)
 229       call ffopen(17,jfname(1))
 230       length = 0
 231       ind = 1
 232
 233       jfname(jf+1)='l'
 234       jfname(jf+2)='c'
 235       jfname(jf+3)='d'
 236       jfname(jf+4)=int2char(0)
 237       call ffcreat(15, jfname(1))
 238
 239       STATUS=0
 240       DO 1 I=1,85
 241 1     BUFOR(I)=DATA1HEX
 242       ON=49
 243       BEGIN=1
 244       IEND=0
 245 800   CALL READIN
 246       I=1
 247 900   if(ord(bufor(i)).ne.ord(ichar(' '))) goto 1000
 248       I=I+1
 249       IF (I.GT.MAX) GOTO 800
 250       GOTO 900
 251 1000  IF (BUFOR(I  ).NE.ICHAR('P').AND.BUFOR(I).NE.ICHAR('p'))
 252      X GOTO 2500
 253       IF (BUFOR(I+1).NE.ICHAR('R').AND.BUFOR(I+1).NE.ICHAR('r'))
 254      X  GOTO 2500
 255       IF (BUFOR(I+2).NE.ICHAR('O').AND.BUFOR(I+2).NE.ICHAR('o'))
 256      X GOTO 2500
 257       IF (BUFOR(I+3).NE.ICHAR('G').AND.BUFOR(I+3).NE.ICHAR('g'))
 258      X GOTO 2500
 259       IF (BUFOR(I+4).NE.ICHAR('R').AND.BUFOR(I+4).NE.ICHAR('r'))
 260      X GOTO 2500
 261       IF (BUFOR(I+5).NE.ICHAR('A').AND.BUFOR(I+5).NE.ICHAR('a'))
 262      X GOTO 2500
 263       IF (BUFOR(I+6).NE.ICHAR('M').AND.BUFOR(I+6).NE.ICHAR('m'))
 264      X GOTO 2500
 265       IF (BUFOR(I+7).EQ.1) GOTO 1100
 266       if(ord(bufor(i+7)) .ne. ord(ichar(' '))) goto 2500
 267 1100  I=I+8
 268       IF (I.LT.MAX) GOTO 1200
 269 1150  CALL READIN
 270       I=1
 271 1200  if(ord(bufor(i)).ne.ord(ichar(' '))) goto 1300
 272       I=I+1
 273       IF (I.GT.MAX) GOTO 1150
 274       GOTO 1200
 275 1300  BEGIN=I
 276       IEND=I-1
 277 1350  IF ((ORD(BUFOR(I)).LT.10).OR.(ORD(BUFOR(I)).GT.35)) GOTO 1500
 278 1400  I=I+1
 279       IF (BUFOR(I).GE.ICHAR('0').AND.BUFOR(I).LE.ICHAR('9')) GOTO 1400
 280       GOTO 1350
 281 1500  IEND=I-1
 282 C
 283 C   INITIALIZE STRINGS OUTPUT TO LFILE WITH EMPTY STRING
 284 C
 285
 286 2500  continue
 287
 288 C write length of empty string
 289       call ffwrite_ints(15, 0, 1)
 290 C write empty string itself
 291       call ffwrite_ints(15, 0, 1)
 292
 293 #if ! ( WSIZE == 4 )
 294 C     if H+
 295       if (btest(c0m(2), 12)) call ffwrite_ints(15, 0, 1)
 296 #endif
 297 cbc
 298 C
 299 C   INITIATE THE TABLE OF REAL CONSTANTS
 300 C   THE TWO INITIAL CONSTANTS, WHICH ALWAYS RESIDE IN THE TABLE ARE
 301 C   0.0 AND 1.0
 302 C
 303       EXP=EMBEDE(0.0)
 304       EXP=EMBEDE(1.0)
 305       LP=IEND+1
 306       I=0
 307       IF (IEND.LT.BEGIN) GOTO 3500
 308       S=SBLOCK
 309       GOTO 4000
 310 3500  IF (S.EQ.70) CALL ERROR(191)
 311 3550  CALL SCAN
 312 3600  IF (S.EQ.SBLOCK)    GOTO 4000
 313       I=1
 314       IF (S.EQ.SBEGIN)    GOTO 4000
 315       IF (S.EQ.SUNIT)     GOTO 4000
 316       IF (S.EQ.SVAR)      GOTO 4000
 317       IF (S.EQ.SCONS)     GOTO 4000
 318       IF (S.EQ.SEND)      GOTO 4000
 319       IF (S.EQ.SPRCD)     GOTO 4000
 320       IF (S.EQ.SFUNCT)    GOTO 4000
 321       IF (S.EQ.SCLASS)    GOTO 4000
 322       IF (S.EQ.SIDENT)    GOTO 3550
 323       IF (S.EQ.STAKEN)    GOTO 4000
 324       IF (S.EQ.SCLOSE)    GOTO 4000
 325       IF (S.LT.25)        GOTO 4000
 326       IF (S.NE.70)        GOTO 3550
 327       CALL ERROR(136)
 328 4000  IF (I.EQ.1) CALL ERROR(137)
 329       RETURN
 330       END
 331
 332 cdeb  new procedures
 333
 334       subroutine inbr
 335       implicit integer(a-z)
 336
 337 cdeb ----------- added ----------------------
 338 c  new common blockfor the debugger
 339       common /debug/ deb,breakt(500),brnr,maxbr
 340       logical deb
 341 c  deb = true - compilation with the debugger
 342 c  breakt - array of static break points
 343 c  brnr - index in breakt
 344 c  maxbr - maximal number of static break points
 345 cdeb ----------------------------------------
 346
 347       character jfname
 348       character int2char
 349       common /jf/ jfname(72), jf
 350
 351       brnr = 0
 352       maxbr = 500
 353       do 10 i=1,maxbr
 354  10   breakt(i) = 0
 355 c  file na hash, breakt, keys
 356       jfname(jf+1) = 'd'
 357       jfname(jf+2) = 'e'
 358       jfname(jf+3) = 'b'
 359       jfname(jf+4) = int2char(0)
 360       call ffcreat(21, jfname(1))
 361       return
 362       end
 363
 364       subroutine addbr(l)
 365       implicit integer(a-z)
 366
 367 cdeb ----------- added ----------------------
 368 c  new common blockfor the debugger
 369       common /debug/ deb,breakt(500),brnr,maxbr
 370       logical deb
 371 c  deb = true - compilation with the debugger
 372 c  breakt - array of static break points
 373 c  brnr - index in breakt
 374 c  maxbr - maximal number of static break points
 375 cdeb ----------------------------------------
 376
 377 c   wstawia do breakt linie o  numerze l
 378
 379       if(.not. deb) return
 380       do 100 i=1,brnr
 381 c  czy juz jest
 382       if(l.eq.breakt(i)) return
 383 100   continue
 384 c  nowy punkt lamiacy
 385       if(brnr.ge.maxbr) return
 386 c  nadmiarowe punkty lamiace sa ignorowane
 387       brnr = brnr+1
 388       breakt(brnr) = l
 389       return
 390       end
 391
 392       subroutine endbr
 393       implicit integer(a-z)
 394       common /BLANK/ com(302),
 395      x          hash(8000), dow(13), keys(200),
 396      x          rest(2000)
 397
 398 cdeb ----------- added ----------------------
 399 c  new common blockfor the debugger
 400       common /debug/ deb,breakt(500),brnr,maxbr
 401       logical deb
 402 c  deb = true - compilation with the debugger
 403 c  breakt - array of static break points
 404 c  brnr - index in breakt
 405 c  maxbr - maximal number of static break points
 406 cdeb ----------------------------------------
 407
 408 c  wypisuje na plik 21 tablice hash
 409       call ffwrite_ints(21, hash, 8000)
 410 cps      call ffwrite_ints(21, keys, 200)
 411 cps      call ffwrite_ints(21, brnr, 1)
 412 cps      call ffwrite_ints(21, breakt, brnr)
 413       return
 414       end
 415
 416 cdeb
 417
 418
 419       SUBROUTINE PEND
 420       IMPLICIT INTEGER (A-Z)
 421       logical errflg
 422       integer endmsg(20)
 423       character*40 endms1
 424       equivalence (endmsg(1), endms1)
 425       COMMON /LISTING/ OUTSTR(265)
 426       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
 427       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
 428       COMMON /BLANK/ C0M(4)
 429       LOGICAL BTEST
 430       character int2char
 431       data endms1 /'end of parsing -------------------------'/
 432       LN=LN+1
 433       call ffwrhex(16, ln)
 434 c
 435       IF (BTEST(C0M(2),15)) GOTO 1
 436       call ffwrite_char(16, '0')
 437 c
 438       GOTO 2
 439 1     call ffwrite_char(16, '1')
 440 c
 441 2     CONTINUE
 442       call ffwrite(16, endmsg(1), 40)
 443 c end of line - write CR/LF
 444       call ffwrite_char(16, int2char(13))
 445       call ffwrite_char(16, int2char(10))
 446 3     IF (BUFOR(1).EQ.2) RETURN
 447       CALL READIN
 448       GOTO 3
 449       END
 450
 451
 452
 453
 454       SUBROUTINE E0
 455 C  ORGANIZATION OF THE STACK:
 456 C     STACK(TOP)   - STACK TOP FOR THE INVOKING MODULE
 457 C     STACK(TOP+1) - NUMBER OF THE INVOKING MODULEY
 458 C     STACK(TOP+2) - NUMBER OF THE RETURN POINT TO THE INVOKING MODULE
 459 C  THE LOCAL VARIABLES, IF ANY ARE USED IN THE MODULE, ARE ALLOCATED ON THE
 460 C  STACK STARTING FROM TOP+3 UP.
 461 C  AN INVOKING MODULE HAS TO APPROPRIATELY INCREMENT THE TOP OF THE STACK
 462 C  RESPECTING ITS LOCAL VARIABLES, THEN STORE ITS NUMBER AND RETURN POINT
 463 C  ON THE STACK AND TRANSFER THE CONTROL TO THE SUPERVISING PROGRAM (RETURN).
 464 C  AFTER RETURN FROM THE CALLED PROGRAM THE STACK TOP IS APPROPRIATELY
 465 C  RESET BY THE SUPERVISING PROGRAM.
 466 C  THE PATTERN OF TRANSFERRING CONTROL:
 467 C     NEXT= N   -  CONTROL TO BE PASSED TO THE MODULE NUMBER N;
 468 C     NEXT= 0   -  RETURN TO THE CALLER.
 469 C  UPON ENTRY TO A SUBPROGRAM
 470 C  PARAMETER - KEEPS THE NUMBER OF PLACE FROM WHICH THE COMPUTATIONS HAVE TO
 471 C  BE CONTINUED
 472       IMPLICIT INTEGER (A-Z)
 473       COMMON /BLANK/
 474      $   C0M(4),
 475      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 476      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 477      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 478      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 479      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 480      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 481      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 482      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 483      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 484      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 485      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 486      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 487      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 488      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 489      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 490      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 491      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 492      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 493
 494       common /BLANK/
 495      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 496      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 497      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 498      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 499      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 500      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 501      N   COM(132),
 502      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 503      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 504      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 505      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 506      $   scaner(8735)
 507 cdsw $   SCANER(3735),
 508
 509       common /BLANK/
 510      Z   TOP,      IN,       NEXT,     STACK(500),
 511      *   RESZTA(3652)
 512       STACK(1)=0
 513       STACK(2)=0
 514       STACK(3)=0
 515       TOP=1
 516 C  NOTE: THE FIRST CALL OF E11, I.E. FOR THE MAIN BLOCK, IS NON-STANDARD.
 517 C        IN IS ASSIGNED VALUE 5 INSTEAD OF STANDARD (1). THIS FACILITATES
 518 C        THE TEXT ANALYSIS OF A PROGRAM WHICH DOESN-T START WITH 'BLOCK'.
 519       IN = 5
 520       NEXT=11
 521       IF (S.EQ.70) GOTO 10025
 522       IF (S.NE.SBLOCK) CALL ERROR(122)
 523       CALL OUTPUT(WBLOCK,ISFIN)
 524       STACK(TOP+4)=0
 525       GOTO 110
 526 C   E11 IS CALLED WITH THE PARAMETER (TOP+4)=0, WHICH MEANS THAT NO PREFIX
 527 C   IS SPECIFIED. E11 ANALYSES THE ENTIRE SYNTACTICAL UNIT.
 528 10    CALL E1
 529       GOTO 1000
 530 20    CALL E2
 531       GOTO 1000
 532 30    CALL E3
 533       GOTO 1000
 534 40    CALL E4
 535       GOTO 1000
 536 50    CALL E5
 537       GOTO 1000
 538 60    CALL E6
 539       GOTO 1000
 540 70    CALL E7
 541       GOTO 1000
 542 80    CALL E8
 543       GOTO 1000
 544 90    CALL E9
 545       GOTO 1000
 546 100   CALL E10
 547       GOTO 1000
 548 110   CALL E11
 549       GOTO 1000
 550 120   CALL E12
 551       GOTO 1000
 552 130   CALL E13
 553 1000  IN = 1
 554       IF (NEXT.EQ.0) GOTO 1002
 555 1001  CONTINUE
 556       GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130),NEXT
 557 1002  IN = STACK(TOP+2)
 558       NEXT = STACK(TOP+1)
 559       TOP = STACK(TOP)
 560       IF (TOP.GT.0) GOTO 1001
 561 10025 CALL PEND
 562       RETURN
 563       END
 564
 565       SUBROUTINE E1
 566 C  E1 - RECOGNIZES BOOLEAN EXPRESSION
 567 C  LOCAL VARIABLES:
 568 C    STACK(TOP+3) - NUMBER OF RECOGNIZED AND-S
 569 C    STACK(TOP+4) - NUMBER OF RECOGNIZED OR-S
 570 C    STACK(TOP+5) - RELATION CODE
 571 C    STACK(TOP+6) - 1 IFF 'NOT' HAS BEEN ENCOUNTERED, 0 IN THE OPPOSITE CASE
 572       IMPLICIT INTEGER (A-Z)
 573       COMMON /BLANK/
 574      $   C0M(4),
 575      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 576      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 577      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 578      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 579      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 580      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 581      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 582      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 583      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 584      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 585      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 586      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 587      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 588      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 589      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 590      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 591      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 592      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 593
 594        common /BLANK/
 595      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 596      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 597      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 598      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 599      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 600      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 601      N   COM(132),
 602      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 603      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 604      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 605      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 606      $   scaner(8735)
 607 cdsw $   SCANER(3735)
 608
 609       common /BLANK/
 610      Z   TOP,      IN,       NEXT,     STACK(500),
 611      *   RESZTA(3652)
 612 cdsw  INTEGER WEOF0,WEOF1,WEOLN0,WEOLN1
 613 cdsw  DATA WEOF0,WEOF1,WEOLN0,WEOLN1/79,80,85,86/
 614       DATA SEOFSI/60/
 615       GOTO (10,20,30,40),IN
 616 10    STACK(TOP+4)=0
 617 411   STACK(TOP+4)=STACK(TOP+4)+1
 618       IF (STACK(TOP+4).GT.1) CALL SCAN
 619       STACK(TOP+3)=0
 620 420   STACK(TOP+3)=STACK(TOP+3)+1
 621       IF (STACK(TOP+3).GT.1) CALL SCAN
 622       STACK(TOP+6)=0
 623       IF (S.NE.SNOT) GOTO 400
 624       STACK(TOP+6)=1
 625       CALL SCAN
 626 400   IF (S.NE.STRUE) GOTO 401
 627 C  A BOOLEAN CONSTANT HAS BEEN ENCOUNTERED. ITS WRITING OUT IS SPLIT
 628 C  INTO TWO STAGES BECAUSE THE VALUE TRUE (-1) CANNOT STAND FOR THE
 629 C  SECOND PARAMETER OF THE WRITING PROCEDURE (OUTPUT).
 630       CALL OUTPUT(WCNSTB,-1)
 631       CALL OUTPUT(1-ADRES,-1)
 632       CALL SCAN
 633       GOTO 300
 634 401   IF (S.NE.SEOFSI) GOTO 402
 635       IF (ADRES.NE.1) ADRES=7
 636 C  79+7-1=85
 637       STACK(TOP+5)=SEOFSI+18+ADRES
 638       CALL SCAN
 639       IF (S.NE.SLEFT) GOTO 444
 640       STACK(TOP+5)=STACK(TOP+5)+1
 641       CALL SCAN
 642       CALL SLAD(4,1,4)
 643       NEXT=3
 644       RETURN
 645 C CALL OBJECTEXPRESSION /E3/
 646 40    IF (S.EQ.SRIGHT) GOTO 430
 647       CALL ERROR(107)
 648       GOTO 444
 649 430   CALL SCAN
 650 444   CALL OUTPUT(STACK(TOP+5),-1)
 651       GOTO 300
 652 C
 653 402   CALL SLAD(4,1,2)
 654       NEXT=2
 655 C  CALL E2 - ARITHMETIC EXPRESSION
 656       RETURN
 657 20    IF (S.NE.SRELAT) GOTO 300
 658       IF (ADRES.GT.2) GOTO 22
 659 C  RECOGNIZED RELATION IS OR IN
 660       STACK(TOP+5)=ADRES
 661       CALL SCAN
 662       IF (S.EQ.SCOROUT) GOTO 205
 663       IF (S.EQ.SIDENT) GOTO 21
 664       CALL ERROR(109)
 665       ADRES=0
 666       GOTO 21
 667 205   CALL OUTPUT(WIDENT,K)
 668 C  FOR "PROCESS", "COROUTINE" THE HASH ADDRESS IS PASSED BY K
 669       GOTO 215
 670 21    CALL OUTPUT(WIDENT,ADRES)
 671 215   CALL SCAN
 672       CALL OUTPUT(WRELAT,STACK(TOP+5))
 673       GOTO 300
 674 22    STACK(TOP+5)=ADRES
 675       CALL SCAN
 676       CALL SLAD(4,1,3)
 677       NEXT=2
 678 C  NEXT CALL FOR E2 - ARITHMETIC EXPRESSION
 679       RETURN
 680 30    CALL OUTPUT(WRELAT,STACK(TOP+5))
 681 300   IF (STACK(TOP+6).EQ.1) CALL OUTPUT(WNOT,-1)
 682       IF (STACK(TOP+3).GT.1) CALL OUTPUT(WAND,-1)
 683       IF (S.EQ.SAND) GOTO 420
 684       IF (STACK(TOP+4).GT.1) CALL OUTPUT(WOR,-1)
 685       IF (S.EQ.SOR) GOTO 411
 686       NEXT=0
 687       RETURN
 688       END
 689       SUBROUTINE E2
 690 C
 691 C  E2 - RECOGNIZES ARITHMETIC EXPRESSION
 692 C  LOKAL VARIABLES:
 693 C    STACK(TOP+3) - MULTIPLICATIVE (HIGHER PRIORITY) OPERATOR
 694 C    STACK(TOP+4) - ADDITIVE (LOWER PRIORITY) OPERATOR
 695 C    STACK(TOP+5) - CONTAINS 1 IF SIGN CHANGE IS REQUIRED, 0 IF NOT,
 696 C    STACK(TOP+6) - CONTAINS 1 IF "ABS" HAS OCCURRED,
 697 C    STACK(TOP+7) - KEEPS LOWER/UPPER OPERATOR KIND,
 698 C    STACK(TOP+8) - INCLUDES 1 IF THE VARIABLE AFTER LOWER/UPPER IS IN
 699 C                   PARANTHESES.
 700 C            NOTE:  THE LAST TWO FIELDS ARE ONLY USED IF THE PERTINET
 701 C                   OPERATOR HAS BEEN ENCOUNTERED. THUS THIS PROCEDURE MAY
 702 C                   BE INVOKED WITH DIFFERENT SIZES OF THE AREA FOR LOCAL
 703 C                   VARIABLES, DEPENDING ON THE CONTENTS.
 704 C
 705       IMPLICIT INTEGER (A-Z)
 706       COMMON /BLANK/
 707      $   C0M(4),
 708      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 709      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 710      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 711      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 712      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 713      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 714      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 715      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 716      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 717      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 718      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 719      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 720      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 721      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 722      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 723      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 724      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 725      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 726
 727       common /BLANK/
 728      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 729      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 730      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 731      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 732      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 733      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 734      N   COM(132),
 735      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 736      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 737      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 738      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 739      $   scaner(8735)
 740 cdsw $   SCANER(3735),
 741
 742       common /BLANK/
 743      Z   TOP,      IN,       NEXT,     STACK(500),
 744      *   RESZTA(3652)
 745       EQUIVALENCE (WEOF,WSIGN)
 746       DATA SLOWUP,WLOWER /79,64/
 747       DATA SIGN/58/
 748 C**********************************************************************
 749 C****** SLOWUP, WLOWER, WUPPER SHOUD BE PUT INTO BLANK
 750 C****** COMMON AT THE NEAREST OPPORTUNITY.
 751 C****** *********** 13.01.1982 *************
 752 C**********************************************************************
 753       GOTO (10,20,30,40,50),IN
 754 C
 755 C  INITIALIZE LOCAL VARIABLES
 756 C
 757 10    STACK(TOP+4)=0
 758       STACK(TOP+5)=0
 759       STACK(TOP+6)=0
 760 C
 761 C  CHECK FOR MINUS (-)
 762 C
 763       IF (S.NE.STAR) GOTO 100
 764       IF (ADRES.GT.4) GOTO 80
 765       GOTO (100,100,70,75),ADRES
 766 C
 767 C  THERE WAS MINUS
 768 C
 769 75    STACK(TOP+5)=1
 770       GOTO 90
 771 C
 772 C  PLUS (+) ENCOUNTERED
 773 C
 774 70    CALL SCAN
 775       GOTO 100
 776 C
 777 C  THE EXPRESSION STARTS WITH * , / , DIV , MOD
 778 C
 779 80    CALL ERROR(126)
 780 90    CALL SCAN
 781 100   STACK(TOP+3)=0
 782 C
 783 C  START OF ANALYSING A SUM COMPONENT
 784 C
 785 110   IF (STACK(TOP+4).NE.0) CALL SCAN
 786 C
 787 C  START OF ANALYSING A MULTIPLICATIVE COMPONENT
 788 C
 789 120   IF (STACK(TOP+3).NE.0) CALL SCAN
 790 C
 791 C  CHECK FOR ABS
 792 C
 793       IF (S.NE.STAR) GOTO 122
 794       IF (ADRES.NE.1) GOTO 122
 795 C
 796 C  ABS ENCOUNTERED
 797 C
 798       STACK(TOP+6)=1
 799       CALL SCAN
 800 C
 801 C  CHECK FOR A CONSTANT, IF AFFIRMATIVE THEN RECOGNIZE ITS TYPE
 802 C
 803 122   IF (S.NE.SCONST) GOTO 130
 804       GOTO (210,210,125,127,123,128),K
 805 C
 806 C  REAL CONSTANT
 807 C
 808 123   CALL OUTPUT(WCNSTR,ADRES)
 809       CALL SCAN
 810       GOTO 180
 811 C
 812 C  INTEGER CONSTANT
 813 C
 814 125   CALL OUTPUT(WCNSTI,ADRES)
 815       CALL SCAN
 816       GOTO 180
 817 C
 818 C  STRING CONSTANT
 819 C
 820 127   CALL OUTPUT(WCNST,ADRES)
 821       GOTO 129
 822 C
 823 C  CHARACTER CONSTANT
 824 C
 825 128   CALL OUTPUT(WCNSTC,ADRES)
 826 129   CALL SCAN
 827 C
 828 C  CHECK AGAINST AN OCCURRENCE OF A STRING/CHAR CONSTANT WITHIN AN EXPRESSION
 829 C
 830       IF (STACK(TOP+3)+STACK(TOP+4)+STACK(TOP+5)+STACK(TOP+6).NE.0)
 831      X                     CALL ERROR(115)
 832       GOTO 210
 833 C
 834 C  CHECK IF THE MULTIPLICATIVE COMPONENT IS AN EXPRESSION
 835 C
 836 130   IF (S.NE.SLEFT) GOTO 160
 837       CALL SCAN
 838       CALL SLAD(4,2,2)
 839       NEXT=1
 840       RETURN
 841 C
 842 C  CALL E1 - BOOLEAN EXPRESSION
 843 C  AFTER RETURN CHECK IF THE EXPRESSION IS TERMINATED BY THEW RIGHT
 844 C  PARANTHESIS
 845 C
 846 20    IF (S.EQ.SRIGHT) GOTO 140
 847       CALL ERROR(101)
 848       GOTO 180
 849 140   CALL SCAN
 850       GOTO 180
 851 160   IF (S.EQ.SLOWUP) GOTO 170
 852       IF (S.EQ.SIGN)   GOTO 165
 853       CALL SLAD(4,2,3)
 854       NEXT=3
 855 C
 856 C  CALL E3 - OBJECTEXPRESSION TO ANALYSE THE VARIABLE
 857 C  RETURN TO LABEL 30 BELOW - JUMP OPTIMIZATION
 858 C
 859       RETURN
 860 C
 861 C  "SIGN" ENCOUNTERED, ARITHMETIC EXPRESSION SHOULD FOLOW.
 862 C
 863 165   CALL SCAN
 864       CALL SLAD(5,2,5)
 865       NEXT=1
 866       RETURN
 867 C
 868 C  CALL E1 TO ANALYSE THE EXPRESSION
 869 C
 870 50    CALL OUTPUT(WSIGN,-1)
 871       GOTO 180
 872 C
 873 C  LOWER/UPPER HAS BEEN ENCOUNTERED. WE HAVE TO REMEMBER WHICH ONE AND CALL
 874 C  OBJECTEXPRESSION TO ANALYSE THE VARIABLE. THE LOCAL VARIABLE FIELD IS
 875 C  INCREASED TO 5 VARIABLES.
 876 C
 877 170   STACK(TOP+7)=ADRES
 878       CALL SCAN
 879       STACK(TOP+8)=0
 880       IF (S.NE.SLEFT) GOTO 172
 881 C                                      THERE WAS A LEFT PARANTHESIS
 882       STACK(TOP+8)=1
 883       CALL SCAN
 884 172   CALL SLAD(6,2,4)
 885       NEXT=3
 886       RETURN
 887 C  CALL E3 - OBJECT EXPRESSION, AFTER RETURN THE OPERATOR TYPE
 888 C  (LOWER/UPPER) IS TO BE WRITTEN
 889 40    CALL OUTPUT(WLOWER+STACK(TOP+7)-1,-1)
 890       IF (STACK(TOP+8).EQ.0) GOTO 30
 891       IF (S.EQ.SRIGHT) GOTO 44
 892 C                                     NO MATCHING RIGHT PARANTHESIS
 893       CALL ERROR(101)
 894       GOTO 30
 895 44    CALL SCAN
 896 30    CONTINUE
 897 180   IF (STACK(TOP+6).NE.1) GOTO 185
 898 C
 899 C  ABS BEFORE THE MULTIPLICATIVE COMPONENT
 900 C
 901       CALL OUTPUT(WOPERAT,1)
 902       STACK(TOP+6)=0
 903 185   IF (STACK(TOP+5).NE.1) GOTO 190
 904 C
 905 C  MINUS BEFORE THE MULTIPLICATIVE COMPONENT
 906 C
 907       CALL OUTPUT(WOPERAT,2)
 908       STACK(TOP+5)=0
 909 190   IF (STACK(TOP+3).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+3))
 910       STACK(TOP+3)=0
 911 C
 912 C  AND OF THE ANALYSIS OF THE COMPONENT, CHECK WHETHER MORE COMPONENTS ARE
 913 C  EXPECTED, E.G. IF THERE OCCURRS * , / , DIV , MOD
 914 C
 915       IF (S.NE.STAR) GOTO 200
 916       IF (ADRES.LT.5) GOTO 200
 917       STACK(TOP+3)=ADRES
 918       GOTO 120
 919 C
 920 C  END OF MULTIPLICATIVE SEQUENCE
 921 C
 922 200   IF (STACK(TOP+4).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+4))
 923       STACK(TOP+4)=0
 924 C
 925 C  END OF AN ADDITIVE COMPONENT, CHECK FOR MORE (+,-)
 926 C
 927       IF (S.NE.STAR) GOTO 210
 928       IF (ADRES.LT.3) GOTO 210
 929       STACK(TOP+4)=ADRES
 930       GOTO 110
 931 C
 932 C  END OF ADDITIVE SEQUENCE
 933 C
 934 210   NEXT=0
 935       RETURN
 936       END
 937