sources/pass1/ml2.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 ML2
  17 C*****************************************************************************
  18 C             ETAP KONCZACY KOMPILACJE
  19 C             ZADANIA:
  20 C               -PRZESORTOWANIE SYGNALIZACJI BLEDOW
  21 C               -LISTING PROGRAMU ZRODLOWEGO Z WSTAWIONYMI SYGNALIZACJAMI
  22 C               -W PRZYPADKU BLEDOW : ABORTOWANIE KOMPILATORA
  23 C
  24 C*****************************************************************************
  25 C
  26 C             OPIS W DOKUMENTACJI:        J.I.3
  27 C             WERSJA Z DNIA:              19.01.82
  28 C             DLUGOSC KODU:       615
  29 C..........................................................................
  30 C
  31       IMPLICIT INTEGER (A-Z)
  32 C
  33       LOGICAL  ERRFLG
  34       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
  35       COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
  36      X          COM(272),
  37      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
  38      X        XFIL(17),
  39      X        IPMEM(5000)
  40       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
  41      X              LN1, LGTH1, BUFLN1(30),
  42      X              LN2, LGTH2, BUFLN2(30),
  43      X              LUN
  44       integer*4 bufln1, bufln2
  45       INTEGER*2 ERRSGN
  46       COMMON /ERRS/  ERRSGN(3, 426)
  47 C
  48       COMMON /MSTA/ MLFREE, WNFREE, WNSTK, AL1BLK, AL1STK,
  49      X              AL2BLK, AL2SYM, AL2OTH, WNBLK, TLP, TLM,
  50      X              WNSUS, TOTMEM
  51 C
  52       LOGICAL BTEST
  53        dimension dig(4)
  54 cdsw    BYTE JFNAME
  55         COMMON /JF/JFNAME(72),JF
  56 cbc
  57       integer*2 bigbuf
  58       common /combuf/ ind, length, bigbuf(16000)
  59 cbc
  60       integer*4 offset
  61       character ch
  62        character jfname
  63        character*72 nam
  64        equivalence(jfname(1),nam)
  65
  66 cdeb --------------------- added =----------------
  67       common /debug/deb,breakt(500),brnr,maxbr
  68       logical deb
  69 cdeb ---------------------------------------
  70
  71       pagesz = 60
  72       pagenr = 0
  73       linpg = 60
  74 C------ PRZYGOTOWANIE WYDRUKOW STATYSTYK
  75       TOTMEM = LMEM+302
  76       TOTMEM = IAND(ISHFT(TOTMEM, -10), 63)
  77       MLFREE = IOP(4)+1
  78       WNFREE = IPMEM(ISFIN-2)
  79       WNSTK = IPMEM(ISFIN-1)
  80       WNSUS = (LPMEM-ISFIN) + WNSTK + 9
  81       WNBLK = IPMEM(ISFIN-8)
  82       AL1BLK = IPMEM(ISFIN-3)
  83       AL1STK = IPMEM(ISFIN-4)
  84 C     AL2BLK = IPMEM(ISFIN-5)
  85 C     AL2SYM = IPMEM(ISFIN-6)
  86 C     AL2OTH = IPMEM(ISFIN-7)
  87       TLP = LPMEM
  88       TLM = LMEM
  89
  90       offset = 0
  91       call ffseek(16,offset)
  92       length = 0
  93       ind = 1
  94
  95       do 117 i=1,4
  96       call frdchr(16, ch)
  97 117   dig(i) = ichar(ch)
  98       call dec(i,dig)
  99       LUN = 0
 100       IF(.NOT.(BTEST(I,15)))    GOTO 9999
 101       LUN = 13
 102       jfname(jf+1) = 'l'
 103       jfname(jf+2) = 's'
 104       jfname(jf+3) = 't'
 105
 106 c  unit 13 - listing  (sequential)
 107       call ffcreat(13,nam)
 108 C ---
 109 9999      IF(ERRFLG)GO TO 1000
 110 C*******GDY PROGRAM  JEST POPRAWNY
 111 C ---
 112       IF (LUN.EQ.0) GOTO 2500
 113 C ---
 114       LPMF = 1
 115 C     WSTAWIENIE STRAZNIKA DO TABLICY SYGNALIZACJI BLEDOW
 116 cdsw&bc      ERRSGN(1,1) = 10000
 117       ERRSGN(1,1) = 32000
 118 c
 119       LPML = 1
 120       GOTO  2000
 121 C
 122 C*******GDY PROGRAM NIEPOPRAWNY
 123 C             -PRZYGOTOWANIE DO LACZENIA LISTINGU I SYGNALIZACJI BLEDOW
 124  1000 LPMF = 1
 125       DO  100 I =1, 425
 126 cdsw&bc ERRSGN(1, I) = 10000
 127         ERRSGN(1, I) = 32000
 128   100 CONTINUE
 129       LPML = 0
 130 C   ... SCIAGNIECIE TABLICY HASH'U
 131       CALL  MGHASH
 132 C   ... SCIAGNIECIE  I POSORTOWANIE SYGNALIZACJI BLEDOW
 133       CALL  MGERR
 134 C   ... SKLEJENIE SYGNALIZACJI PARSERA ODWOLUJACYCH SIE DO TEJ
 135 C       SAMEJ LINII
 136        CALL  MFLTR
 137 C
 138 C***************  LISTOWANIE PROGRAMU
 139 2000  CALL  MLSTSC
 140 C------ PRZYGOTOWANIE ZAKONCZENIA KOMPILACJI
 141 2500  CONTINUE
 142 C------ PROGRAM POPRAWNY
 143       IF (.NOT. ERRFLG) GOTO 7770
 144 C------ PROGRAM NIEPOPRAWNY
 145 3000  IF (ERRCNT .EQ. 0)        GOTO  3100
 146       call ffputnl(0)
 147       call ffputi (0,ERRCNT,4)
 148       call ffputcs(0,' error(s) detected')
 149       call ffputnl(0)
 150 3100  IF (IOP(1) .LE. 7)    GOTO  3200
 151       call ffputcs(0,' Fatal Error:  Source program abandoned')
 152       call ffputnl(0)
 153 3200  CONTINUE
 154 7770  CONTINUE
 155
 156       call closf(ibuf3)
 157
 158       call ffclose(15)
 159       if (errflg) call ffunlink(15)
 160       call ffclose(16)
 161 C  16 is temporary file and will be automatically deleted after exit, but ...
 162       call ffunlink(16)
 163       call ffclose(17)
 164 cdeb ------------------ added --------------
 165 c deletion of the file 21 (for debugger )
 166       if(.not.deb) go to 10
 167       deb = .false.
 168       call ffclose(21)
 169       if (errflg) call ffunlink(21)
 170 10    continue
 171 cdeb
 172 cvax  STOP
 173       END
 174
 175 cdsw ------------  added  -------------------------------
 176       subroutine dec(num,dig)
 177       implicit integer (a-z)
 178       dimension dig(4)
 179 c  zamienia 4 cyfry hexadecymalne wpisane w dig na liczbe num
 180 c
 181       do 10 i=1,4
 182       a = iand(dig(i),X'00ff')
 183       if(a.ge.ichar('a').and. a.le.ichar('f') ) go to 100
 184       if(a.ge.ichar('A').and.a.le.ichar('F')) go to 99
 185       a = a-ichar('0')
 186       go to 110
 187  100  a = a-ichar('a')+10
 188       go to 110
 189  99   a = a-ichar('A')+10
 190  110  dig(i) = a
 191  10   continue
 192       num = dig(4)
 193       num = ior(num,ishft(dig(1),12))
 194       num = ior(num,ishft(dig(2),8))
 195       num = ior(num,ishft(dig(3),4))
 196       return
 197       end
 198
 199
 200
 201       SUBROUTINE  MLSTSC
 202 C--------------PROCEDURA LISTUJACA TEKST ZRODLOWY (SOURCE) I
 203 C             WSTAWIAJACA DO NIEGO SYGNALIZACJE BLEDOW
 204 C
 205 C             OPIS W DOKUMENTACJI:          J.III.1
 206 C             WERSJA Z DNIA:                19.01.82
 207 C             DLUGOSC KODU:       420
 208 C..........................................................................
 209 C
 210       IMPLICIT INTEGER (A-Z)
 211       LOGICAL  MREADLN, MREADSG
 212       LOGICAL  PRINT1, PRINT2
 213 C             PRINT1, PRINT2 - FLAGI DRUKOWANIA LINII W BUFORACH BUFLN
 214 C
 215       COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
 216      X          COM(272),
 217      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 218      X        XFIL(17),
 219      X        IPMEM(5000)
 220       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 221      X              LN1, LGTH1, BUFLN1(30),
 222      X              LN2, LGTH2, BUFLN2(30),
 223      X              LUN
 224       integer*4 bufln1, bufln2
 225       INTEGER*2 ERRSGN
 226       COMMON /ERRS/  ERRSGN(3, 426)
 227 C
 228 C-------------
 229       ERRLINE = ERRSGN(1, LPMF)
 230       NR = ERRSGN(2, LPMF)
 231       ID = ERRSGN(3, LPMF)
 232 C......WCZYTANIE PIERWSZEJ LINII LISTINGU
 233       PRINT2 = MREADLN(PRINT1)
 234       LN1 = LN2
 235       LGTH1 = LGTH2
 236       DO  100  I=1, (LGTH1+3)/4
 237         BUFLN1(I) = BUFLN2(I)
 238   100 CONTINUE
 239 C********************************
 240 C     WCZYTYWANIE KOLEJNYCH LINII
 241  1000 IF (MREADLN(PRINT2) )    GOTO  5000
 242 C             --SKOK, GDY SKONCZYL SIE TEKST ZRODLOWY, W BUFLN1 JEST JEGO
 243 C               OSTATNIA LINIA
 244 C     --- SPRAWDZENIE, CZY LINIA W BUFLN2 NIE ZAWIERA LINII Z SYGNALI-
 245 C          ZACJA BLEDU Z PARSERA
 246       IF (LN1 .NE. LN2)    GOTO  2000
 247 C     ---DRUKOWANIE LINII Z BUFLN1 Z INFORMACJA O TYM, ZE ZA NIA
 248 C                 BEDA SYGNALIZACJE BLEDOW
 249 C     (W CZASIE DRUKOWANIA BUFLN2 JEST PRZEPISYWANY DO BUFLN1)
 250       CALL  PSLINE(.TRUE.)
 251       PRINT1 = PRINT2
 252 C     ---CZYTANIE I KOMPRESJA LINII Z SYGNALIZACJAMI BLEDOW Z PARSERA
 253 C        - PIERWSZA LINIA ZNAJDUJE SIE W BUFLN1
 254       IF (MREADSG(PRINT2))    GOTO  5000
 255 C        W BUFLN1 JEST SKOMPRESOWANA LINIA Z SYGNALIZACJAMI
 256 C        O ILE NIE MA SKOKU - W BUFLN2 JEST NOWA LINIA TEKSTU ZRODLOWEGO
 257 C        SKOK - GDY SKONCZYL SIE TEKST ZRODLOWY
 258 C        WYDRUKOWANIE OSTATNIEJ LINII Z SYGNALIZACJA BLEDOW PARSERA
 259          CALL  PSLINE (.FALSE.)
 260          GOTO  3100
 261 C
 262  2000 IF (LN2 .GT. ERRLINE)    GOTO  3000
 263 C     ---NOWA LINIA POPRZEDZA SYGNALIZACJE BLEDOW
 264       IF (PRINT1)    CALL  PSLINE(.FALSE.)
 265       IF (PRINT1)    GOTO  2500
 266 C     ...SKOPIOWANIE BUFORA (NIE MUSI BYC W PSLINE)
 267         LN1 = LN2
 268         LGTH1 = LGTH2
 269         DO 2100 I=1, (LGTH1+3)/4
 270           BUFLN1(I) = BUFLN2(I)
 271  2100   CONTINUE
 272  2500 PRINT1 = PRINT2
 273       GOTO  1000
 274 C     ---NOWA LINIA WYSTEPUJE ZA SYGNALIZACJA BLEDOW
 275  3000 CALL  PSLINE(.TRUE.)
 276       PRINT1 = PRINT2
 277 C     ---WYPISANIE SYGNALIZACJI BLEDOW ODNOSZACYCH SIE DO WYDRUKOWANEJ
 278 C        LINII
 279  3100 CALL  PERSGN(ERRLINE, NR, ID)
 280  3150 LPMF = LPMF+1
 281       ERRLINE = ERRSGN(1, LPMF)
 282 cdsw&bc  added check for guard - ERRLINE = 32000
 283       if (errline .eq. 32000) goto 8000
 284 c
 285       NR = ERRSGN(2, LPMF)
 286       ID = ERRSGN(3, LPMF)
 287       IF (NR .EQ. -1)    GOTO  3150
 288 C          SKOK - GDY TA SYGNALIZACJA ZOSTALA POMINIETA PRZEZ FILTROWANIE
 289       IF (ERRLINE .LT. LN1)    GOTO  3100
 290 C        SKOK GDY NASTEPNA SYGNALIZACJA ODNOSI SIE DO LINII JUZ WYDRUKOWANEJ
 291 C     ...LINIA ZA SYGNALIZACJA BLEDOW TEZ MUSI BYC DRUKOWANA
 292       PRINT1 = .TRUE.
 293       GOTO  1000
 294 C-----------------------------
 295 C     ZAKONCZENIE LISTINGU - W BUFLN1 JEST OSTATNIA LINIA
 296 cdsw&bc 5000 IF (ERRLINE .EQ. 10000)     GOTO  7000
 297  5000 IF (ERRLINE .EQ. 32000)    GOTO  7000
 298 C             --JEST TO PSEUDOSYGNALIZACJA (STRAZNIK)
 299       CALL  PSLINE(.TRUE.)
 300 C     ---WYPISANIE RESZTY SYGNALIZACJI BLEDOW
 301  6000 IF (NR .NE. -1)    CALL  PERSGN(ERRLINE, NR, ID)
 302       LPMF = LPMF+1
 303       ERRLINE = ERRSGN(1, LPMF)
 304 cdsw&bc      IF (ERRLINE .EQ. 10000)     GOTO  8000
 305       IF (ERRLINE .EQ. 32000)    GOTO  8000
 306       NR = ERRSGN(2, LPMF)
 307       ID = ERRSGN(3, LPMF)
 308       GOTO  6000
 309 C     ---WYPISANIE OSTATNIEJ LINII Z LISTINGU, GDY ZA NIA NIE MA
 310 C        SYGNALIZACJI BLEDOW
 311  7000 IF (PRINT1)    CALL  PSLINE(.FALSE.)
 312  8000 RETURN
 313       END
 314
 315       SUBROUTINE  PERSGN(LINE, NR, ID)
 316 C--------------PROCEDURA DRUKUJACA SYGNALIZACJE BLEDOW
 317 C             LINE - NUMER LINII Z BLEDEM
 318 C             NR - NUMER BLEDU
 319 C             ID - IDENTYFIKATOR
 320 C
 321 C             OPIS W DOKUMENTACJI:         J.III.6
 322 C             WERSJA Z DNIA:               19.01.82
 323 C             DLUGOSC KODU:       4865
 324 C.....................................................................
 325 C             !!!!!! UWAGA !!!!!!
 326 C             PO FORTRANIE (PRZED ASSEMBLACJA) DOLACZYC
 327 C             ZAWARTOSC DECKU  MPERSGNASS PRZED 'END'
 328 C               -- ZAWIERA ON INICJALIZACJE TABLIC SYGNALIZACJI
 329 C             BLEDOW
 330 C
 331       IMPLICIT INTEGER (A-Z)
 332       character itab(8)
 333       equivalence (itab(1),nameid(1))
 334
 335       LOGICAL BTEST
 336       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 337      X              LN1, LGTH1, BUFLN1(30),
 338      X              LN2, LGTH2, BUFLN2(30),
 339      X              LUN
 340       integer*4 bufln1, bufln2
 341
 342       DIMENSION NAMEID(2)
 343       integer*4 nameid
 344
 345       DO 201 I=1,8
 346 201   ITAB(I)=' '
 347
 348       LINPG = LINPG + 1
 349       IF (LINPG .GT. PAGESZ)    CALL PGINIT
 350
 351 C     ---DRUKOWANIE SYGNALIZACJI
 352 202   IF (ID .EQ. 0)    GOTO  400
 353       IF (ID .LT. 0)    GOTO  300
 354 C     ---ODKODOWANIE NAZWY
 355       IF (.NOT. BTEST(ID, 0))    GOTO  400
 356 C         -- W TYM PRZYPADKU NIE JEST TO IDENTYFIKATOR LECZ SLOWO KLUCZOWE
 357       call naswa(id,itab)
 358       GOTO  400
 359
 360 C     ---ODKODOWANIE ZNAKU
 361 300   nameid(1) = -id-1
 362 400   continue
 363
 364       CALL listing_error_line( lun, line, nr, NR, nameid(1) )
 365       RETURN
 366       END
 367
 368
 369       SUBROUTINE  MFLTR
 370 C-----------------PROCEDURA FILTRUJE SYGNALIZACJE BLEDOW - SKLEJA
 371 C                 SYGNALIZACJE O TYM SAMYM NUMERZE POCHODZACE Z
 372 C                 PARSERA I ODNOSZACE SIE DO TEJ SAMEJ LINII TEKSTU
 373 C                 ZRODLOWEGO
 374 C
 375 C             OPIS W DOKUMENTACJI:           J.II.4
 376 C             WERSJA Z DNIA:                 19.01.82
 377 C             DLUGOSC KODU:       202
 378 C........................................................................
 379 C
 380       IMPLICIT INTEGER (A-Z)
 381 C
 382       COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
 383      X          COM(272),
 384      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 385      X        XFIL(17),
 386      X        IPMEM(5000)
 387       INTEGER*2 ERRSGN
 388       COMMON /ERRS/  ERRSGN(3, 426)
 389 C
 390 C
 391 C                 IER100 - ZAWIERA OSTATNIE LINIE TEKSTU W
 392 C                           KTORYCH SYGNALIZOWANO BLAD Z PRZEDZIALU
 393 C                           101-143
 394 C                 IER200 - ANALOGICZNIE DLA PRZEDZIALU 201-212
 395       INTEGER*2 IER100(43), IER200(12)
 396       DATA IER100 /43*0/, IER200 /12*0/
 397 C
 398 C
 399       DO 1000 I=LPMF,LPML
 400 C     ...NRERR - NUMER BLEDU
 401         NRERR = ERRSGN(2,I)
 402         IF(NRERR .LE. 100)    GOTO  1000
 403         IF (NRERR .GE. 213)    GOTO  1000
 404         IF ( (NRERR .GE. 144) .AND. (NRERR .LE. 200) )    GOTO  1000
 405 C             TE SYGNALIZACJE NIE PODLEGAJA SKLEJANIU
 406 C     ...NRLINE - NUMER LINII
 407         NRLINE = ERRSGN(1,I)
 408         IF (NRERR .GT. 200)    GOTO  500
 409 C     ---TU BLAD Z PRZEDZIALU 101-143
 410           NRERR = NRERR-100
 411           IF (IER100(NRERR) .NE. NRLINE)    GOTO  100
 412 C         BLAD JUZ SYGNALIZOWANY
 413             ERRSGN(2,I) = -1
 414             GOTO    1000
 415 C         ZAPAMIETANIE LINII Z TA SYGNALIZACJA
 416   100     IER100(NRERR) = NRLINE
 417             GOTO  1000
 418 C     ---TU BLAD Z PRZEDZIALU 201-212
 419   500   NRERR= NRERR-200
 420         IF (IER200(NRERR) .NE. NRLINE)    GOTO  600
 421 C         BLAD JUZ SYGNALIZOWANY
 422           ERRSGN(2,I) = -1
 423           GOTO  1000
 424 C         ZAPAMIETANIE LINII
 425   600     IER200(NRERR) = NRLINE
 426 C
 427  1000 CONTINUE
 428       RETURN
 429       END
 430       LOGICAL FUNCTION  MREADSG(PRINTER)
 431 C----------------------FUNKCJA CZYTA ORAZ WYKONUJE KOMPRESJE LINII
 432 C                      ZAWIERAJACYCH SYGNALIZACJE BLEDOW PARSERA.
 433 C                     WARUNEK WEJSCIOWY: BUFLN1 ZAWIERA OSTATNIA
 434 C                      LINIE (PIERWSZA Z SYGNALIZACJA BLEDOW PAR-
 435 C                      SERA)
 436 C                      BUFLN2 JEST PUSTY
 437 C                     WARUNEK WYJSCIOWY: BUFLN1 ZAWIERA OSTATNIA
 438 C                      SKOMPRESOWANA LINIE Z SYGNALIZACJAMI
 439 C                      BUFLN2 KOLEJNA LINIE TEKSTU ZRODLOWEGO
 440 C                      LUB JEST PUSTY (GDY TEKST SIE SKONCZYL)
 441 C                      WARTOSC FUNKCJI .TRUE. OZNACZA ZE TEKST
 442 C                      ZRODLOWY SIE SKONCZYL
 443 C
 444 C
 445 C             OPIS W DOKUMENTACJI:          J.III.5
 446 C             WERSJA Z DNIA:                19.01.82
 447 C             DLUGOSC KODU:        402
 448 C..........................................................................
 449 C
 450       IMPLICIT INTEGER (A-Z)
 451       LOGICAL MREADLN
 452       LOGICAL PRINTER
 453 C               PRINTER FLAGA DRUKOWANIA LINII Z BUFLN2
 454 C
 455       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 456      X              LN1, LGTH1, BUFLN1(30),
 457      X              LN2, LGTH2, BUFLN2(30),
 458      X              LUN
 459        integer*4 bufln1, bufln2
 460 C ---
 461       character bln1(120), bln2(120)
 462       EQUIVALENCE (BLN1(1),BUFLN1(1)),(BLN2(1),BUFLN2(1))
 463 C ---
 464 C
 465 C
 466 C
 467       MREADSG = .TRUE.
 468  1000 CONTINUE
 469       DO 1 I=LGTH1-2,LGTH1
 470       BLN1(I-3) = BLN1(I)
 471 1     CONTINUE
 472       LGTH1 = LGTH1 - 3
 473         BLN1(LGTH1+1)= ' '
 474         BLN1(LGTH1+2)=' '
 475         BLN1(LGTH1+3)=' '
 476 C-----LINIA W BUFLN1 JEST SKOMPRESOWANA
 477 C     WCZYTANIE KOLEJNEJ LINII DO BUFLN2
 478         IF (MREADLN(PRINTER))    RETURN
 479 C        POWROT, GDY BYLA TO OSTATNIA LINIA (MREADSG = .TRUE.)
 480         IF (LN1 .NE. LN2)    GOTO  9000
 481 C        --LINIA W BUFLN2 NIE JEST SYGNALIZACJA BLEDU - SKOK
 482 C     ---NOWA LINIA Z SYGNALIZACJA BLEDU
 483 C        SPRAWDZENIE, CZY  ?  W BUFLN2 JEST DALEJ NIZ WYNOSI
 484 C        DLUGOSC LINII W BUFLN1, TZN. CZY LINIE MOGA BYC SKLEJONE
 485          IF (LGTH1 .LT. (LGTH2-6))    GOTO  3000
 486 C        ----TU LINIE NIE MOGA BYC SKLEJONE
 487 C          WYDRUKOWANIE LINII Z BUFLN1 Z PRZESLANIEM ZAWARTOSCI BUFORA
 488 C          BUFLN2 DO BUFLN1 I PRZEJSCIE DO KOMPRESJI NOWEJ SYGNALIZACJI
 489             CALL  PSLINE(.FALSE.)
 490             GOTO  1000
 491 C        ---DOKLEJANIE LINII Z BUFLN2 DO BUFLN1
 492 3000  DO 3200 I=LGTH1+1,LGTH2
 493       BLN1(I) = BLN2(I)
 494  3200   CONTINUE
 495         LGTH1 = LGTH2
 496         GOTO  1000
 497 C------ZAKONCZENIE
 498  9000 MREADSG = .FALSE.
 499       RETURN
 500       END
 501
 502
 503       SUBROUTINE NASWA(L,ITAB)
 504 C
 505 C  PARAMETR L - NUMER IDENTYFIKATORA Z TABLICY HASH
 506 C
 507 C             OPIS W DOKUMENTACJI:         J.III.6
 508 C             WERSJA Z DNIA:               19.01.82
 509 C             DLUGOSC KODU:        120
 510 C.....................................................................
 511       IMPLICIT INTEGER (A-Z)
 512       COMMON /BLANK/ COM(302),HASH(8000),M,I,K
 513
 514       character itab(8)
 515       I=L
 516       J=1
 517       IF (HASH(I).LE.0) RETURN
 518 5     IF (HASH(I).LT.61) GOTO 10
 519 C  DWA ZNAKI W SLOWIE
 520       K=ISHFT(HASH(I),-6)
 521       itab(j) = char(snak(k))
 522       J=J+1
 523 C  JEDEN ZNAK
 524 10    K=IAND(HASH(I),63)
 525       itab(j) = char(snak(k))
 526       J=J+1
 527       I=HASH(I+1)
 528       IF (I.GE.0) RETURN
 529       I=-I
 530       GOTO 5
 531       END
 532
 533
 534       INTEGER FUNCTION SNAK(K)
 535       IMPLICIT INTEGER (A-Z)
 536       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 537      X              LN1, LGTH1, BUFLN1(30),
 538      X              LN2, LGTH2, BUFLN2(30),
 539      X              LUN
 540        integer*4 bufln1, bufln2
 541       IF (K.EQ.60) K=0
 542       IF (K.GT.9) GOTO 10
 543 C  CYFRA - KOD MIEDZY 0 A 9
 544       SNAK = K + ICHAR('0')
 545       RETURN
 546 10    IF (K.GT.35) GOTO 20
 547 C  LITERA - KOD MIEDZY 10 A 35
 548       SNAK = ICHAR('A') + K - 10
 549       RETURN
 550 C  LACZNIK - UNDERSCORE
 551 20    SNAK = ICHAR('_')
 552       RETURN
 553       END
 554       SUBROUTINE  MGHASH
 555 C--------------SCIAGNIECIE TABLICY NAZW (HASH'U) SCANNERA DO
 556 C             SYGNALIZACJI BLEDOW
 557 C
 558 C             OPIS W DOKUMENTACJI:           J.II.1
 559 C             WERSJA Z DNIA:                 19.01.82
 560 C             DLUGOSC KODU:        330
 561 C......................................................................
 562 C
 563       IMPLICIT INTEGER (A-Z)
 564 C
 565       LOGICAL  ERRFLG
 566       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
 567       COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
 568      X          COM(272),
 569      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 570      X        XFIL(17),
 571      x        hash(8000)
 572 cdsw X        IPMEM(5000)
 573       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 574      X              LN1, LGTH1, BUFLN1(30),
 575      X              LN2, LGTH2, BUFLN2(30),
 576      X              LUN
 577       integer*4 bufln1, bufln2
 578 C
 579       CALL  SEEK(IBUF3, 0)
 580       do 100 i=1,8000,256
 581       call get(ibuf3,hash(i))
 582   100 CONTINUE
 583       RETURN
 584       END
 585
 586
 587       SUBROUTINE  PSLINE (WSIGN)
 588 C--------------DRUKUJE LINIE TEKSTU ZRODLOWEGO PRZECHOWYWANA
 589 C             W BUFLN1.
 590 C             WSIGN - .TRUE. - OZNACZA, ZE DO LINII BEDZIE ODNO-
 591 C             SILA SIE ROWNIEZ INFORMACJA O BLEDZIE, W ZWIAZKU Z TYM
 592 C             LINIA TA NIE POWINNA BYC OSTATNIA LINIA NA STRONIE
 593 C
 594 C             OPIS W DOKUMENTACJI:        J.III.3
 595 C             WERSJA Z DNIA:              19.01.82
 596 C             DLUGOSC KODU:       153
 597 C.....................................................................
 598 C
 599       IMPLICIT INTEGER (A-Z)
 600       LOGICAL  WSIGN
 601 C
 602       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 603      X              LN1, LGTH1, BUFLN1(30),
 604      X              LN2, LGTH2, BUFLN2(30),
 605      X              LUN
 606       integer*4 bufln1, bufln2
 607 cailvax
 608 c     Maximal record length for the printer is 132 characters (VAX).
 609 c     Hence only 114 characters remain for the source line.
 610       character buf(114)
 611       equivalence (buf(1),bufln1(1))
 612
 613       LINPG = LINPG + 1
 614       IF (LINPG .GT. PAGESZ)    GOTO  2000
 615 C           --SKONCZYLA SIE STRONA
 616       IF (WSIGN .AND. (LINPG .EQ. PAGESZ) )    GOTO  2000
 617 C           --NA STRONIE NIE ZMIESCI SIE LINIA RAZEM Z SYGNA-
 618 C             LIZACJA, ROZPOCZECIE NOWEJ STRONY
 619
 620 1000  k = lgth1
 621       if (k .gt. 114) k = 114
 622
 623 cailvax  that's a pity those 6 characters are truncated
 624 cvax ---------- added
 625
 626       call ffputcs(lun,'    ')
 627       call ffputi (lun,ln1,6)
 628       call ffputcs(lun,'      ')
 629       call ffputs (lun,buf,k)
 630       call ffputnl(lun)
 631
 632       LN1 = LN2
 633       LGTH1 = LGTH2
 634       LGTH2 = (LGTH2+3)/4
 635       DO  1100 I=1, LGTH2
 636       BUFLN1(I) = BUFLN2(I)
 637  1100 CONTINUE
 638       RETURN
 639  2000 CALL  PGINIT
 640       GOTO  1000
 641       END
 642
 643
 644
 645       SUBROUTINE  PGINIT
 646 C--------------ROZPOCZECIE NOWEJ STRONY LISTINGU
 647 C
 648 C             OPIS W DOKUMENTACJI:         J.III.2
 649 C             WERSJA Z DNIA:               19.01.82
 650 C             DLUGOSC KODU:       162
 651 C.......................................................................
 652
 653       IMPLICIT INTEGER (A-Z)
 654
 655       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 656      X              LN1, LGTH1, BUFLN1(30),
 657      X              LN2, LGTH2, BUFLN2(30),
 658      X              LUN
 659       integer*4 bufln1, bufln2
 660
 661       COMMON /BLANK/ IP(1)
 662
 663       IF (LUN.EQ.2) RETURN
 664       PAGENR = PAGENR + 1
 665       LINPG = 1
 666
 667       call ffputnl(LUN)
 668       call ffputff(LUN)
 669       call ffputcs(LUN,'  IIUW   LOGLAN-82')
 670       call ffputcs(LUN,'  UNIX Compiler - Ver. Oct 88')
 671       call ffputspaces(LUN,15)
 672       call ffputcs(LUN,'PAGE ')
 673       call ffputi (LUN,PAGENR,7)
 674       call ffputnl(LUN)
 675
 676       RETURN
 677       END
 678
 679
 680
 681       SUBROUTINE  MGERR
 682 C--------------SCIAGNIECIE ZE STRUMIENIA 2  SYGNALIZACJI BLEDOW,
 683 C             POSORTOWANIE ICH WZGLEDEM NUMEROW LINII W TEKSCIE
 684 C             ZRODLOWYM (PROCEDURA  MSERR)
 685 C             POSORTOWANE SYGNALIACJE ZNAJDUJA SIE W TABLICY
 686 C             ERRSGN  (COMMON /ERRS/) OD MIEJSCA LPMF DO LPML
 687 C             DOPUSZCZALNA LICZBA SYGNALIZACJI  425 - INACZEJ PRZE-
 688 C             PELNIENIE  10
 689 C
 690 C             ZMIENIONE  (WSZYSTKO BYLO DO DUPY)     P.G.
 691 C             =========                 =======
 692 C
 693 C........................................................................
 694 C
 695       IMPLICIT INTEGER (A-Z)
 696 C
 697       LOGICAL  ERRFLG
 698       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
 699       COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
 700      X          COM(272),
 701      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 702      X        XFIL(17),
 703      X        IPMEM(5000)
 704       INTEGER*2 ERRSGN
 705       COMMON /ERRS/  ERRSGN(3, 426)
 706 C
 707 C             BUDOWA STRUMIENIA  2
 708 C       SLOWA 1-7 -BUFOR DLA PROCEDUR ZAPISU I ODCZYTU (OPIS STRUMIENIA)
 709 C       SLOWO 8 -NUMER AKTUALNIE ZAPISYWANEGO BLOKU
 710 C       SLOWO 9 -INDEKS PIERWSZEJ WOLNEJ POZYCJI BLOKU AKTUALNIE TWORZO-
 711 C             NEGO
 712 C       SLOWO 10 -LICZBA TROJEK WPISANYCH DO BLOKU
 713 C       SLOWA 10-265 -AKTUALNIE TWORZONY BLOK (TROJKI ZAPISYWANE OD SLO-
 714 C             WA 11)
 715 C
 716       LPMF = IBUF2(8)*85
 717       ERRCNT = LPMF + (IBUF2(9) - 11)/3
 718 C             ERRCNT - LICZBA SYGNALIZACJI BLEDOW
 719       LPML = ERRCNT
 720       IF (ERRCNT .GT. 425)    GOTO  2000
 721 C             --SKOK GDY LICZBA SYGNALIZACJI BLEDOW PRZEKRACZA
 722 C             DOPUSZCZALNA
 723 C
 724 C --- SYTUACJA NORMALNA - LICZBA SYGNALIZACJI BLEDOW JEST DOPUSZCZALNA
 725       IF (ERRCNT .EQ. LPMF)    GOTO  200
 726 C ... PRZEPISANIE TROJEK SYGNALIZACJI BLEDOW Z BUFORA  IBUF2
 727 C       DO TABLICY ERRSGN
 728       K = IBUF2(9) - 1
 729       DO  100  I=11, K, 3
 730         LPMF = LPMF+1
 731         ERRSGN(1, LPMF) = IBUF2(I)
 732         ERRSGN(2, LPMF) = IBUF2(I+1)
 733         ERRSGN(3, LPMF) = IBUF2(I+2)
 734   100 CONTINUE
 735 C
 736 C...WCZYTANIE SYGNALIZACJI BLEDOW ZE STRUMIENIA 2
 737   200 CALL  SEEK(IBUF2, 0)
 738       K =  IBUF2(8)
 739 C             ... K LICZBA BLOKOW
 740       IF (K .EQ. 0)    GOTO  5000
 741  1000 LPMF = 0
 742       DO  1200  I=1, K
 743         CALL  GET(IBUF2, IBUF2(10)  )
 744         DO  1100  J=11, 265, 3
 745           LPMF = LPMF+1
 746           ERRSGN(1, LPMF) = IBUF2(J)
 747           ERRSGN(2, LPMF) = IBUF2(J+1)
 748           ERRSGN(3, LPMF) = IBUF2(J+2)
 749  1100   CONTINUE
 750  1200 CONTINUE
 751 C  ... PRZEJSCIE DO CZESCI SORTUJACEJ
 752       GOTO  5000
 753 C
 754 C
 755 C-----SYTUACJA PRZEKROCZENIA DOPUSZCZALNEJ LICZBY SYGNALIZACJI
 756 C     -WCZYTANIE PIERWSZYCH 425 SYGNALIZACJI, TJ. 8 BLOKOW
 757 C      SYG. 500 BEDZIE OPISYWAC PRZEKROCZENIE TABLICY SYGNALIZACJI
 758 C
 759  2000 IOP(1) = 1
 760       K = IBUF2(8)
 761       CALL  SEEK(IBUF2, K)
 762       CALL PUT(IBUF2, IBUF2(10) )
 763       CALL  SEEK(IBUF2, 0)
 764       LPMF = 0
 765       DO  2200  I=1,5
 766         CALL  GET(IBUF2, IBUF2(10))
 767         DO  2100 J=11, 265, 3
 768           LPMF = LPMF+1
 769           ERRSGN(1,LPMF) = IBUF2(J)
 770           ERRSGN(2, LPMF) = IBUF2(J+1)
 771           ERRSGN(3, LPMF) = IBUF2(J+2)
 772  2100   CONTINUE
 773  2200 CONTINUE
 774       ERRSGN(1, 425) = 9999
 775       ERRSGN(2, 425) = 10
 776       ERRSGN(3, 425) = 0
 777       LPML = 425
 778 C
 779 C
 780 C*******SORTOWANIE SYGNALIZACJI BLEDOW
 781  5000 CALL  MSERR
 782 cdsw&bc      ERRSGN(1,LPML+1) = 10000
 783       ERRSGN(1,LPML+1) = 32000
 784       CALL  CLOSF(IBUF2)
 785       RETURN
 786       END
 787
 788
 789
 790       LOGICAL FUNCTION  MREADLN (PRINTF)
 791 C--------------PROCEDURA WCZYTUJE LINIE WSTEPNIE UTWORZONEGO
 792 C             LISTINGU (ZE STRUMIENIA 1) DO BUFORA  BUFLN2
 793 C             PRINTF - FLAGA LISTOWANIA LINII, MA WARTOSC
 794 C                      .TRUE. GDY LINIE NALEZY WYDRUKOWAC
 795 C             //DODATKOWO MREADLN  MA WARTOSC .TRUE., GDY NAPOTKANY
 796 C             JEST KONIEC PLIKU
 797 C
 798 C             OPIS W DOKUMENTACJI:          J.III.4
 799 C             WERSJA Z DNIA:                19.01.82
 800 C             DLUGOSC KODU:        225
 801 C..........................................................................
 802 C
 803       IMPLICIT INTEGER (A-Z)
 804       LOGICAL  PRINTF
 805 C
 806       COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
 807      X          COM(272),
 808      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 809      X        XFIL(17),
 810      X        IPMEM(5000)
 811 C
 812       COMMON /LYST/ PAGESZ, PAGENR, LINPG,
 813      X              LN1, LGTH1, BUFLN1(30),
 814      X              LN2, LGTH2, BUFLN2(30),
 815      X              LUN
 816       integer*4 bufln1,  bufln2
 817       character bufln3(120)
 818       equivalence (bufln2(1), bufln3(1))
 819       character ch
 820       character bln2(4)
 821       integer*4 bufelem
 822       dimension dig(4)
 823       EQUIVALENCE(BUFELEM,BLN2(1))
 824
 825       DATA BS / '    ' /
 826
 827       MREADLN = .FALSE.
 828       do 118 i=1,4
 829       call frdchr(16, ch)
 830       dig(i) = ichar(ch)
 831       if (dig(i) .eq. 2) goto 1000
 832 118   continue
 833       call dec(ln2,dig)
 834       call frdchr(16, ch)
 835       pfg = ichar(ch)-48
 836       do 119 i=1,120
 837       call frdchr(16, bufln3(i))
 838       if (ichar(bufln3(i)) .eq. 1) goto 121
 839 119   continue
 840 121   continue
 841       do 122 j=i, 120
 842 122   bufln3(j) = ' '
 843 cdsw&bc
 844       LGTH2 = 1
 845       DO 2 I=2,30
 846       IF (BUFLN2(I).NE.BS) LGTH2 = I
 847 2     CONTINUE
 848       PRINTF = (PFG.NE.0) .AND. (LUN.EQ.13)
 849          BUFELEM = BUFLN2(LGTH2)
 850       LGTH2 = 4*LGTH2
 851         DO 10 I=4,1,-1
 852         IF(BLN2(I).NE.' ')RETURN
 853 10      LGTH2 = LGTH2-1
 854         RETURN
 855 C---------KONIEC TEKSTU ZRODLOWEGO
 856  1000 MREADLN = .TRUE.
 857       RETURN
 858       END
 859
 860
 861
 862       SUBROUTINE  MSERR
 863 C--------------PROCEDURA SORTOWANIA SYGNALIZACJI BLEDOW.
 864 C              ALGORYTM:
 865 C               - SORTOWANIE PRZEZ WTLACZANIE BLOKOW ZAWIERAJACYCH
 866 C               - (GOWNO - ZWYKLY BUBBLE SORT)   P.G.
 867 C
 868 C.....................................................................
 869 C
 870       IMPLICIT INTEGER (A-Z)
 871       COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
 872      X          COM(272),
 873      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 874      X        XFIL(17),
 875      X        IPMEM(5000)
 876       INTEGER*2 ERRSGN
 877       COMMON /ERRS/  ERRSGN(3, 426)
 878 C
 879       A=LPML-1
 880       LPMF=1
 881       IF(A.LE.0)RETURN
 882       DO 1000 I=1,A
 883       MAX=19999
 884       DO 999 J=I,LPML
 885       IF(ERRSGN(1,J).GT.MAX)GO TO 999
 886       MAX=ERRSGN(1,J)
 887       IMAX=J
 888 999   CONTINUE
 889       J=ERRSGN(1,I)
 890       ERRSGN(1,I)=ERRSGN(1,IMAX)
 891       ERRSGN(1,IMAX)=J
 892       J=ERRSGN(2,I)
 893       ERRSGN(2,I)=ERRSGN(2,IMAX)
 894       ERRSGN(2,IMAX)=J
 895       J=ERRSGN(3,I)
 896       ERRSGN(3,I)=ERRSGN(3,IMAX)
 897       ERRSGN(3,IMAX)=J
 898 1000  CONTINUE
 899       RETURN
 900       END
 901