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
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.
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 ===============================================================
17 C*****************************************************************************
18 C ETAP KONCZACY KOMPILACJE
20 C -PRZESORTOWANIE SYGNALIZACJI BLEDOW
21 C -LISTING PROGRAMU ZRODLOWEGO Z WSTAWIONYMI SYGNALIZACJAMI
22 C -W PRZYPADKU BLEDOW : ABORTOWANIE KOMPILATORA
24 C*****************************************************************************
26 C OPIS W DOKUMENTACJI: J.I.3
27 C WERSJA Z DNIA: 19.01.82
29 C..........................................................................
31 IMPLICIT INTEGER (A-Z)
34 COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
35 COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
37 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
40 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
41 X LN1, LGTH1, BUFLN1(30),
42 X LN2, LGTH2, BUFLN2(30),
44 integer*4 bufln1, bufln2
46 COMMON /ERRS/ ERRSGN(3, 426)
48 COMMON /MSTA/ MLFREE, WNFREE, WNSTK, AL1BLK, AL1STK,
49 X AL2BLK, AL2SYM, AL2OTH, WNBLK, TLP, TLM,
55 COMMON /JF/JFNAME(72),JF
58 common /combuf/ ind, length, bigbuf(16000)
64 equivalence(jfname(1),nam)
66 cdeb --------------------- added =----------------
67 common /debug/deb,breakt(500),brnr,maxbr
69 cdeb ---------------------------------------
74 C------ PRZYGOTOWANIE WYDRUKOW STATYSTYK
76 TOTMEM = IAND(ISHFT(TOTMEM, -10), 63)
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)
91 call ffseek(16,offset)
97 117 dig(i) = ichar(ch)
100 IF(.NOT.(BTEST(I,15))) GOTO 9999
106 c unit 13 - listing (sequential)
109 9999 IF(ERRFLG)GO TO 1000
110 C*******GDY PROGRAM JEST POPRAWNY
112 IF (LUN.EQ.0) GOTO 2500
115 C WSTAWIENIE STRAZNIKA DO TABLICY SYGNALIZACJI BLEDOW
116 cdsw&bc ERRSGN(1,1) = 10000
122 C*******GDY PROGRAM NIEPOPRAWNY
123 C -PRZYGOTOWANIE DO LACZENIA LISTINGU I SYGNALIZACJI BLEDOW
126 cdsw&bc ERRSGN(1, I) = 10000
130 C ... SCIAGNIECIE TABLICY HASH'U
132 C ... SCIAGNIECIE I POSORTOWANIE SYGNALIZACJI BLEDOW
134 C ... SKLEJENIE SYGNALIZACJI PARSERA ODWOLUJACYCH SIE DO TEJ
138 C*************** LISTOWANIE PROGRAMU
140 C------ PRZYGOTOWANIE ZAKONCZENIA KOMPILACJI
142 C------ PROGRAM POPRAWNY
143 IF (.NOT. ERRFLG) GOTO 7770
144 C------ PROGRAM NIEPOPRAWNY
145 3000 IF (ERRCNT .EQ. 0) GOTO 3100
147 call ffputi (0,ERRCNT,4)
148 call ffputcs(0,' error(s) detected')
150 3100 IF (IOP(1) .LE. 7) GOTO 3200
151 call ffputcs(0,' Fatal Error: Source program abandoned')
159 if (errflg) call ffunlink(15)
161 C 16 is temporary file and will be automatically deleted after exit, but ...
164 cdeb ------------------ added --------------
165 c deletion of the file 21 (for debugger )
166 if(.not.deb) go to 10
169 if (errflg) call ffunlink(21)
175 cdsw ------------ added -------------------------------
176 subroutine dec(num,dig)
177 implicit integer (a-z)
179 c zamienia 4 cyfry hexadecymalne wpisane w dig na liczbe num
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
187 100 a = a-ichar('a')+10
189 99 a = a-ichar('A')+10
193 num = ior(num,ishft(dig(1),12))
194 num = ior(num,ishft(dig(2),8))
195 num = ior(num,ishft(dig(3),4))
202 C--------------PROCEDURA LISTUJACA TEKST ZRODLOWY (SOURCE) I
203 C WSTAWIAJACA DO NIEGO SYGNALIZACJE BLEDOW
205 C OPIS W DOKUMENTACJI: J.III.1
206 C WERSJA Z DNIA: 19.01.82
208 C..........................................................................
210 IMPLICIT INTEGER (A-Z)
211 LOGICAL MREADLN, MREADSG
212 LOGICAL PRINT1, PRINT2
213 C PRINT1, PRINT2 - FLAGI DRUKOWANIA LINII W BUFORACH BUFLN
215 COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
217 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
220 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
221 X LN1, LGTH1, BUFLN1(30),
222 X LN2, LGTH2, BUFLN2(30),
224 integer*4 bufln1, bufln2
226 COMMON /ERRS/ ERRSGN(3, 426)
229 ERRLINE = ERRSGN(1, LPMF)
232 C......WCZYTANIE PIERWSZEJ LINII LISTINGU
233 PRINT2 = MREADLN(PRINT1)
236 DO 100 I=1, (LGTH1+3)/4
237 BUFLN1(I) = BUFLN2(I)
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
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)
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.)
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)
269 DO 2100 I=1, (LGTH1+3)/4
270 BUFLN1(I) = BUFLN2(I)
274 C ---NOWA LINIA WYSTEPUJE ZA SYGNALIZACJA BLEDOW
275 3000 CALL PSLINE(.TRUE.)
277 C ---WYPISANIE SYGNALIZACJI BLEDOW ODNOSZACYCH SIE DO WYDRUKOWANEJ
279 3100 CALL PERSGN(ERRLINE, NR, ID)
281 ERRLINE = ERRSGN(1, LPMF)
282 cdsw&bc added check for guard - ERRLINE = 32000
283 if (errline .eq. 32000) goto 8000
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
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)
300 C ---WYPISANIE RESZTY SYGNALIZACJI BLEDOW
301 6000 IF (NR .NE. -1) CALL PERSGN(ERRLINE, NR, ID)
303 ERRLINE = ERRSGN(1, LPMF)
304 cdsw&bc IF (ERRLINE .EQ. 10000) GOTO 8000
305 IF (ERRLINE .EQ. 32000) GOTO 8000
309 C ---WYPISANIE OSTATNIEJ LINII Z LISTINGU, GDY ZA NIA NIE MA
310 C SYGNALIZACJI BLEDOW
311 7000 IF (PRINT1) CALL PSLINE(.FALSE.)
315 SUBROUTINE PERSGN(LINE, NR, ID)
316 C--------------PROCEDURA DRUKUJACA SYGNALIZACJE BLEDOW
317 C LINE - NUMER LINII Z BLEDEM
321 C OPIS W DOKUMENTACJI: J.III.6
322 C WERSJA Z DNIA: 19.01.82
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
331 IMPLICIT INTEGER (A-Z)
333 equivalence (itab(1),nameid(1))
336 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
337 X LN1, LGTH1, BUFLN1(30),
338 X LN2, LGTH2, BUFLN2(30),
340 integer*4 bufln1, bufln2
349 IF (LINPG .GT. PAGESZ) CALL PGINIT
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
360 C ---ODKODOWANIE ZNAKU
361 300 nameid(1) = -id-1
364 CALL listing_error_line( lun, line, nr, NR, nameid(1) )
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
375 C OPIS W DOKUMENTACJI: J.II.4
376 C WERSJA Z DNIA: 19.01.82
378 C........................................................................
380 IMPLICIT INTEGER (A-Z)
382 COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
384 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
388 COMMON /ERRS/ ERRSGN(3, 426)
391 C IER100 - ZAWIERA OSTATNIE LINIE TEKSTU W
392 C KTORYCH SYGNALIZOWANO BLAD Z PRZEDZIALU
394 C IER200 - ANALOGICZNIE DLA PRZEDZIALU 201-212
395 INTEGER*2 IER100(43), IER200(12)
396 DATA IER100 /43*0/, IER200 /12*0/
400 C ...NRERR - NUMER BLEDU
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
408 IF (NRERR .GT. 200) GOTO 500
409 C ---TU BLAD Z PRZEDZIALU 101-143
411 IF (IER100(NRERR) .NE. NRLINE) GOTO 100
412 C BLAD JUZ SYGNALIZOWANY
415 C ZAPAMIETANIE LINII Z TA SYGNALIZACJA
416 100 IER100(NRERR) = NRLINE
418 C ---TU BLAD Z PRZEDZIALU 201-212
420 IF (IER200(NRERR) .NE. NRLINE) GOTO 600
421 C BLAD JUZ SYGNALIZOWANY
425 600 IER200(NRERR) = NRLINE
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-
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
445 C OPIS W DOKUMENTACJI: J.III.5
446 C WERSJA Z DNIA: 19.01.82
448 C..........................................................................
450 IMPLICIT INTEGER (A-Z)
453 C PRINTER FLAGA DRUKOWANIA LINII Z BUFLN2
455 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
456 X LN1, LGTH1, BUFLN1(30),
457 X LN2, LGTH2, BUFLN2(30),
459 integer*4 bufln1, bufln2
461 character bln1(120), bln2(120)
462 EQUIVALENCE (BLN1(1),BUFLN1(1)),(BLN2(1),BUFLN2(1))
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
491 C ---DOKLEJANIE LINII Z BUFLN2 DO BUFLN1
492 3000 DO 3200 I=LGTH1+1,LGTH2
498 9000 MREADSG = .FALSE.
503 SUBROUTINE NASWA(L,ITAB)
505 C PARAMETR L - NUMER IDENTYFIKATORA Z TABLICY HASH
507 C OPIS W DOKUMENTACJI: J.III.6
508 C WERSJA Z DNIA: 19.01.82
510 C.....................................................................
511 IMPLICIT INTEGER (A-Z)
512 COMMON /BLANK/ COM(302),HASH(8000),M,I,K
517 IF (HASH(I).LE.0) RETURN
518 5 IF (HASH(I).LT.61) GOTO 10
521 itab(j) = char(snak(k))
524 10 K=IAND(HASH(I),63)
525 itab(j) = char(snak(k))
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),
540 integer*4 bufln1, bufln2
543 C CYFRA - KOD MIEDZY 0 A 9
544 SNAK = K + ICHAR('0')
546 10 IF (K.GT.35) GOTO 20
547 C LITERA - KOD MIEDZY 10 A 35
548 SNAK = ICHAR('A') + K - 10
550 C LACZNIK - UNDERSCORE
555 C--------------SCIAGNIECIE TABLICY NAZW (HASH'U) SCANNERA DO
556 C SYGNALIZACJI BLEDOW
558 C OPIS W DOKUMENTACJI: J.II.1
559 C WERSJA Z DNIA: 19.01.82
561 C......................................................................
563 IMPLICIT INTEGER (A-Z)
566 COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
567 COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
569 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
573 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
574 X LN1, LGTH1, BUFLN1(30),
575 X LN2, LGTH2, BUFLN2(30),
577 integer*4 bufln1, bufln2
581 call get(ibuf3,hash(i))
587 SUBROUTINE PSLINE (WSIGN)
588 C--------------DRUKUJE LINIE TEKSTU ZRODLOWEGO PRZECHOWYWANA
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
594 C OPIS W DOKUMENTACJI: J.III.3
595 C WERSJA Z DNIA: 19.01.82
597 C.....................................................................
599 IMPLICIT INTEGER (A-Z)
602 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
603 X LN1, LGTH1, BUFLN1(30),
604 X LN2, LGTH2, BUFLN2(30),
606 integer*4 bufln1, bufln2
608 c Maximal record length for the printer is 132 characters (VAX).
609 c Hence only 114 characters remain for the source line.
611 equivalence (buf(1),bufln1(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
621 if (k .gt. 114) k = 114
623 cailvax that's a pity those 6 characters are truncated
624 cvax ---------- added
626 call ffputcs(lun,' ')
627 call ffputi (lun,ln1,6)
628 call ffputcs(lun,' ')
629 call ffputs (lun,buf,k)
636 BUFLN1(I) = BUFLN2(I)
646 C--------------ROZPOCZECIE NOWEJ STRONY LISTINGU
648 C OPIS W DOKUMENTACJI: J.III.2
649 C WERSJA Z DNIA: 19.01.82
651 C.......................................................................
653 IMPLICIT INTEGER (A-Z)
655 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
656 X LN1, LGTH1, BUFLN1(30),
657 X LN2, LGTH2, BUFLN2(30),
659 integer*4 bufln1, bufln2
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)
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-
690 C ZMIENIONE (WSZYSTKO BYLO DO DUPY) P.G.
693 C........................................................................
695 IMPLICIT INTEGER (A-Z)
698 COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7), JUNK(260)
699 COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
701 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
705 COMMON /ERRS/ ERRSGN(3, 426)
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-
712 C SLOWO 10 -LICZBA TROJEK WPISANYCH DO BLOKU
713 C SLOWA 10-265 -AKTUALNIE TWORZONY BLOK (TROJKI ZAPISYWANE OD SLO-
717 ERRCNT = LPMF + (IBUF2(9) - 11)/3
718 C ERRCNT - LICZBA SYGNALIZACJI BLEDOW
720 IF (ERRCNT .GT. 425) GOTO 2000
721 C --SKOK GDY LICZBA SYGNALIZACJI BLEDOW PRZEKRACZA
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
731 ERRSGN(1, LPMF) = IBUF2(I)
732 ERRSGN(2, LPMF) = IBUF2(I+1)
733 ERRSGN(3, LPMF) = IBUF2(I+2)
736 C...WCZYTANIE SYGNALIZACJI BLEDOW ZE STRUMIENIA 2
737 200 CALL SEEK(IBUF2, 0)
739 C ... K LICZBA BLOKOW
740 IF (K .EQ. 0) GOTO 5000
743 CALL GET(IBUF2, IBUF2(10) )
746 ERRSGN(1, LPMF) = IBUF2(J)
747 ERRSGN(2, LPMF) = IBUF2(J+1)
748 ERRSGN(3, LPMF) = IBUF2(J+2)
751 C ... PRZEJSCIE DO CZESCI SORTUJACEJ
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
762 CALL PUT(IBUF2, IBUF2(10) )
766 CALL GET(IBUF2, IBUF2(10))
769 ERRSGN(1,LPMF) = IBUF2(J)
770 ERRSGN(2, LPMF) = IBUF2(J+1)
771 ERRSGN(3, LPMF) = IBUF2(J+2)
774 ERRSGN(1, 425) = 9999
780 C*******SORTOWANIE SYGNALIZACJI BLEDOW
782 cdsw&bc ERRSGN(1,LPML+1) = 10000
783 ERRSGN(1,LPML+1) = 32000
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
798 C OPIS W DOKUMENTACJI: J.III.4
799 C WERSJA Z DNIA: 19.01.82
801 C..........................................................................
803 IMPLICIT INTEGER (A-Z)
806 COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
808 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
812 COMMON /LYST/ PAGESZ, PAGENR, LINPG,
813 X LN1, LGTH1, BUFLN1(30),
814 X LN2, LGTH2, BUFLN2(30),
816 integer*4 bufln1, bufln2
817 character bufln3(120)
818 equivalence (bufln2(1), bufln3(1))
823 EQUIVALENCE(BUFELEM,BLN2(1))
831 if (dig(i) .eq. 2) goto 1000
837 call frdchr(16, bufln3(i))
838 if (ichar(bufln3(i)) .eq. 1) goto 121
846 IF (BUFLN2(I).NE.BS) LGTH2 = I
848 PRINTF = (PFG.NE.0) .AND. (LUN.EQ.13)
849 BUFELEM = BUFLN2(LGTH2)
852 IF(BLN2(I).NE.' ')RETURN
855 C---------KONIEC TEKSTU ZRODLOWEGO
856 1000 MREADLN = .TRUE.
863 C--------------PROCEDURA SORTOWANIA SYGNALIZACJI BLEDOW.
865 C - SORTOWANIE PRZEZ WTLACZANIE BLOKOW ZAWIERAJACYCH
866 C - (GOWNO - ZWYKLY BUBBLE SORT) P.G.
868 C.....................................................................
870 IMPLICIT INTEGER (A-Z)
871 COMMON /BLANK/ IOP(4), ERRLINE, ERRCNT,
873 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
877 COMMON /ERRS/ ERRSGN(3, 426)
885 IF(ERRSGN(1,J).GT.MAX)GO TO 999
890 ERRSGN(1,I)=ERRSGN(1,IMAX)
893 ERRSGN(2,I)=ERRSGN(2,IMAX)
896 ERRSGN(3,I)=ERRSGN(3,IMAX)