sources/pass1/al11.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       SUBROUTINE AL1
  17 C-----------------------------------------------------------------------
  18 C
  19 C      1983.01.06
  20 C
  21 C     * * * * * * * * * * * * * * * * * * * *
  22 C
  23 C     THE FOLLOWING FILE UNITS ARE USED :
  24 C
  25 C      1 - INTERACTIVE INPUT FROM THE TERMINAL ( FOR TESTING ONLY )
  26 C      2 - INTERACTIVE OUTPUT TO THE TERMINAL  ( FOR TESTING ONLY )
  27 C     13 - LISTING OUTPUT                      ( TEST MESSAGES    )
  28 C     14 - WORKING FILE SCRATCH       - CODE FROM PARSER AND L-CODE
  29 C                         ( USED ONLY VIA SEEK,PUT,GET WITH IBUF3 )
  30 C     15 - L-CODE OUTPUT   ( TEXTUAL (HEXADECIMAL) REPRESENTATION
  31 C                                      OF SYMBOL TABLE AND L-CODE )
  32 C
  33 C     * * * * * * * * * * * * * * * * * * * *
  34 C
  35 C        STRUMIENIE :
  36 C               3 - BINARNY - KOD Z PARSERA
  37 C               LO - WYDRUKI KONTROLNE /ZNAKOWY/
  38 C               3 - PRODUKOWANE CZWORKI /BINARNY/ - SEKWENCYJNIE,
  39 C                          OD REKORDU NUMER IOP(2)+1 .
  40 C                          /REKORD O NUMERZE IOP(2) BUFORUJE STOS "CASE"/
  41 C
  42 C     * * * * * * * * * * * * * * * * * * * *
  43 C
  44 C
  45 C
  46 C
  47 C     ##### OUTPUT CODE : 200 .
  48 C
  49 C
  50 C
  51 #include "stos.h"
  52 #include "blank.h"
  53 C
  54       COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
  55       LOGICAL ERRFLG
  56 C     IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
  57 C
  58       COMMON/SUMMARY/FREE
  59       COMMON/CASE/DEEP,OVER
  60 C
  61 C
  62 cdeb --------------- added ------------
  63       common /brid/breaklid
  64 c  breaklid - numer w displayu (dla interpretera) procedury breakl
  65
  66       common /debug/deb,breakt(500),brnr,maxbr
  67       logical deb
  68 cdeb -----------------------------------
  69
  70       common/MJLMSG/IERC,MSG
  71 cdsw  ----------------------------
  72       integer*4 msg
  73 cdsw  ----------------------------
  74 cdsw&bc
  75       common /stacks/ btsins, btstem
  76 C
  77 C
  78       IERC=0
  79       msg = 'al1 '
  80 C
  81       CALL STEST
  82 C               WCZYTANA OPCJA WYDRUKOW KONTROLNYCH
  83       CALL SABORT
  84 C               WYLAPANIE ABORTU
  85 C
  86 C
  87       LSTWRD=LMEM-260
  88 C     OSTATNIE ZAJETE SLOWO W BUFORZE WYJSCIOWYM / LMEM-259 .. LMEM-1 /
  89       BOTTOM=LMEM-916
  90       STACK(BOTTOM)=-1
  91 C     DNO STOSU / LMEM-916 .. LMEM-516 /  Z WARTOWNIKIEM = -1
  92       FREE=LMEM-516-BOTTOM
  93 C     ROZMIAR STOSU = 400
  94       DEEP=LMEM-600
  95 C     PUSTY STOS INSTRUKCJI "CASE" / LMEM-515 .. LMEM-260 /
  96       QRECNR=IOP(2)
  97 C     NAJWIEKSZY UZYTY NUMER REKORDU STRUMIENIA 3
  98 C
  99 cdsw&bc
 100       btsins = lpml
 101       btstem = lpmf
 102 cdsw  -----------------  added  ----------------------------------
 103 c  inicjalizacje zmiennych z common przeniesione z podprogramow
 104 c    przeniesione z sinit
 105       stckag = 0
 106       stcka0 = 8
 107       do 1 i=1,14
 108       stckap(i) = 8
 109 1     continue
 110       stckap(5) = 10
 111       stckap(6) = 4
 112       apetyt(1) = 1
 113 #if WSIZE == 4
 114       apetyt(2) = 1
 115 #else
 116       apetyt(2) = 2
 117 #endif
 118       apetyt(3) = 3
 119       apetyt(4) = 2
 120 c   przeniesione z scase
 121       over = 0
 122 cdsw -----------------------------------------------------------------
 123 c
 124       CALL SPASS2
 125 C
 126 cdeb ----------------- added -------------------
 127 c  instrukcja L-kodu przekazujaca breaklid
 128       if (.not.deb) go to 2001
 129       call quadr1(211)
 130       if(breaklid.eq.0) go to 2001
 131       call quadr2(210,breaklid)
 132 2001  continue
 133 cdeb -------------------------------------------
 134 C
 135 C     WYPISZ ZNACZNIK KONCA PRODUKOWANEGO KODU POSREDNIEGO
 136       CALL QUADR1(200)
 137 C     JESLI TRZEBA - WYPISZ BUFOR Z CZWORKAMI
 138       IF(ERRFLG) GO TO 2000
 139       IF(LSTWRD.EQ.LMEM-260)GO TO 1000
 140 cdsw ****************************
 141 cdsw      QRECNR=QRECNR+1
 142 cdsw      CALL SEEK(IBUF3,QRECNR)
 143 cdsw      CALL PUT(IBUF3,IPMEM(LMEM-259))
 144 cbc   write(18) (ipmem(i),i=lmem-259,lmem-4)
 145       call ffwrite_ints(18, ipmem(lmem-259), 256)
 146 cbc
 147 cdsw *****************************
 148 C
 149 C
 150 C     WRITE HEXADECIMAL REPRESENTATION OF SYMBOL TABLE AND L-CODE
 151  1000 CALL SLCSTOUT
 152
 153  2000 CONTINUE
 154
 155       call ffclose(18)
 156 C     CLOSED TEMPORARY 18 should BE AUTOMATICALLY DELETED but ...
 157       call ffunlink(18)
 158
 159 C
 160 C
 161 C     WYLACZ 'RECOVERY'
 162       CALL SRCVOFF
 163 C
 164 C
 165 C.....PRZYGOTUJ DANE STATYSTYCZNE
 166 C
 167 C
 168       IPMEM(ISFIN-3)=QRECNR-IOP(2)
 169 C      = LICZBA WYPRODUKOWANYCH REKORDOW Z KODEM POSREDNIM
 170       IPMEM(ISFIN-4)=(400-FREE)/4
 171 C      = % UZYTEGO STOSU   /WZOR POPRAWNY DLA ROZMIARU = 400 /
 172 C
 173 C
 174 cdsw  MSG=HAL1
 175       CALL MESS
 176 C     PRINT LISTING
 177       CALL ML2
 178 C     STOP
 179 C     PO ABORCIE /BLAD W KOMPILATORZE/
 180 C7777 ERRFLG=.TRUE.     CHANGED TO COMMENT 04.01.84
 181 CBC   GO TO 1000
 182       END
 183
 184
 185       SUBROUTINE SPASS2
 186 C-----------------------------------------------------------------------------
 187 C
 188 C     PROCEDURA STERUJACA PRZEBIEGIEM 2.
 189 C     DWUKROTNIE PRZECHODZI PRZEZ WSZYSTKIE MODULY.
 190 C       FAZA 1 : WYLICZANIE WARTOSCI STALYCH /INIT=TRUE/
 191 C                - WYBIERA TYLKO MODULY ZAWIERAJACE STALE WYLICZANE
 192 C       FAZA 2 : WLASCIWA GENERACJA KODU /INIT=FALSE/
 193 C                - PRZECHODZI PRZEZ WSZYSTKIE MODULY ZAWIERAJACE INSTRUKCJE
 194 C     W OBU FAZACH PRZECHODZI KOLEJNO PRZEZ MODULY I DLA KAZDEGO MODULU
 195 C     WSTAWIA JEGO ADRES DO P ,WCZYTUJE PIERWSZY REKORD Z KODEM POSREDNIM,
 196 C      USTAWIA WB I INDEKS SYMBOLU DLA SNEXT,INICJALIZUJE STRUKTURY DANYCH,
 197 C     WOLA SDPDA.
 198 C
 199 C     STARTUJE OD BLOKU WSKAZANEGO PRZEZ NBLUS.
 200 C     DLA KAZDEGO MODULU REKORDY Z KODEM POSREDNIM Z PARSERA POWIAZANE
 201 C     SA W LISTE : SLOWO +8 ZAWIERA NUMER PIERWSZEGO REKORDU /JESLI SLOWO
 202 C     +9  =0 TO LISTA JEST PUSTA/ A SLOWO +9 INDEKS PIERWSZEGO SYMBOLU
 203 C     W REKORDZIE. SLOWO 256 REKORDU ZAWIERA NUMER NASTEPNEGO REKORDU
 204 C     LISTY. KOD DLA KAZDEGO MODULU JEST ZAKONCZONY PARA <FIN,NUMER ETYKIETY>.
 205 C
 206 C     SLOWO +2 W OPISIE MODULU ZAWIERA ADRES /W IPMEM/ NASTEPNEGO MODULU.
 207 C
 208 #include "stos.h"
 209 #include "blank.h"
 210       COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
 211       LOGICAL ERRFLG
 212 C
 213       COMMON/TEST/TESTC,TESTS,TESTH
 214       LOGICAL TESTC,TESTS,TESTH
 215 C
 216       LOGICAL INIT
 217 C      = TRUE DLA FAZY WYLICZANIA STALYCH
 218 C
 219 C     INTERNAL 2000             CHANGED TO COMMENT 04.01.84
 220 C     PUNKT POWROTU PO PRZEPELNIENIU STOSU W SPUSH
 221 C
 222 C
 223 C................. FAZA WYLICZANIA STALYCH
 224 C                  /PIERWSZE PRZEJSCIE PRZEZ KOD DLA MODULOW/
 225 C
 226       INIT=.TRUE.
 227 C
 228 C.....USTAW P NA BLOK GLOWNY
 229   100 P=NBLUS
 230 C
 231 C
 232 C.....INICJALIZACJA DLA PROTOTYPU P
 233  1000 CONTINUE
 234
 235       IF(.NOT.TESTC) GOTO 5000
 236       call ffputcs(13,' ------------ PASS2 ---------- P =')
 237       call ffputi (13,P,6)
 238       call ffputnl(13)
 239 5000  CONTINUE
 240
 241 C     POMIN,JESLI TO PROTOTYP FORMALNY/PROC.,FUN.,SYGNAL/
 242       IF(IAND(ISHFT(IPMEM(P),-4),15).NE.0)GO TO 2000
 243 C
 244 C ... PODCZAS WYLICZANIA STALYCH POMIN,JESLI MODUL ICH NIE MA
 245       IF(INIT.AND.IPMEM(P-1).EQ.0)GO TO 2000
 246 C
 247 C     POMIN , JESLI NIE MA INSTRUKCJI
 248       IF(IPMEM(P+9).EQ.0)GO TO 2500
 249 C
 250 C ... ODSZUKAJ PIERWSZY REKORD Z KODEM POSREDNIM
 251       N=IPMEM(P+8)
 252 C     WSTAW NUMER I WCZYTAJ PIERWSZY REKORD
 253       IX(258)=N
 254       CALL SEEK(IBUF3,N)
 255
 256       IF(.NOT.TESTC) GOTO 6000
 257       call ffputcs(13,' REKORD')
 258       call ffputi (13,N,5)
 259       call ffputcs(13,'  SYMBOL')
 260       call ffputi (13,IPMEM(P+9),4)
 261       call ffputnl(13)
 262 6000  CONTINUE
 263
 264       CALL GET(IBUF3,IX)
 265       WB=IPMEM(P+9)
 266 C     WSTAW INDEKS BIEZACEGO SYMBOLU,USTAW WB
 267       IX(257)=WB
 268       WB=IX(WB)
 269
 270 C     INICJALIZACJA
 271
 272       CALL MPROTO
 273       CALL SDPDA(INIT)
 274       CALL MPROTC
 275
 276
 277 C...........WEZ NASTEPNY MODUL
 278  2000 P=IPMEM(P+2)
 279       IF(P.NE.0)GO TO 1000
 280 C     WSZYSTKIE MODULY JUZ SKOMPILOWANE.
 281 C
 282 C................. FAZA GENERACJI KODU
 283 C                  /DRUGIE PRZEJSCIE PRZEZ KOD DLA MODULOW/
 284 C
 285       IF(.NOT.INIT)RETURN
 286       INIT=.FALSE.
 287       GO TO 100
 288 C
 289 C
 290 C.....MODUL BEZ INSTRUKCJI. PREFIKS?
 291  2500 IDL=IPMEM(P+21)
 292       IF(IDL.EQ.0)GO TO 2600
 293 C     TAK. PRZEPISZ INFORMACJE O INSTRUKCJACH PO INNER
 294       IPMEM(P-7)=IPMEM(IDL-7)
 295       GO TO 2000
 296 C ... BEZ PREFIKSU. DLA KLASY,REKORDU WSTAW: BRAK INSTR. PO INNER
 297  2600 IF(IAND(IPMEM(P),15).NE.1)IPMEM(P-7)=0
 298 cdsw&bc
 299       if (.not. init) call stclass
 300       GO TO 2000
 301       END
 302
 303
 304       subroutine stclass
 305       implicit integer(a-z)
 306 #include "blank.h"
 307 c
 308 c not yet used as prefix
 309       ipmem(p+1) = 0
 310 c begin of module
 311       call quadr2(184, p)
 312 c begin of instructions
 313       call quadr1(179)
 314 c inner
 315       call quadr2(178, ipmem(p+23))
 316 c after inner label
 317       call quadr2(181, 1)
 318 c fin
 319       call quadr1(194)
 320 c lastwill
 321       call quadr1(174)
 322       ipmem(p+8) = 0
 323 c back
 324       call quadr1(193)
 325 c end module
 326       call quadr1(185)
 327       return
 328       end
 329
 330       SUBROUTINE SDPDA(INICJA)
 331 C-----------------------------------------------------------------------------
 332 C
 333 C     WERSJA 1983.03.09
 334 C
 335 C     GLOBAL JUMPS ARE CHANGED TO LOCAL JUMPS IF POSSIBLE  OTHERWISE THEY ARE
 336 C     CHANGED TO COMPUTED JUMPS  8.5.84
 337 C
 338 C     MAIN ROUTINE OF SEMANTIC ANALYSIS AND CODE GENERATION
 339 C     GLOWNA PROCEDURA ANALIZY SEMANTYCZNEJ I GENERACJI KODU POSREDNIEGO
 340 C     /CZWOREK/ DLA MODULU.
 341 C     PRACUJE JAK DETERMINISTYCZNY AUTOMAT ZE STOSEM STEROWANY SYMBOLEM
 342 C     WEJSCIOWYM.
 343 C     W ZALEZNOSCI OD WB /SYMBOL WEJSCIOWY/ WYBIERANA JEST AKCJA DO WYKONANIA
 344 C     O ETYKIECIE 100*WB : OD 100 DO 7200.
 345 C     WB MUSI MIEC NADANA WARTOSC PRZED WYWOLANIEM SDPDA.
 346 C
 347 C     DLA KAZDEGO MODULU WOLANA DWUKROTNIE:
 348 C      PIERWSZY RAZ W FAZIE WYLICZANIA STALYCH /O ILE MODUL ZAWIERAL
 349 C       STALE WYLICZANE/ I DRUGI RAZ W FAZIE GENERACJI KODU /O ILE
 350 C       BYLY INSTRUKCJE/.
 351 C     W FAZIE WYLICZANIA STALYCH PO WYSTAPIENIU ZNACZNIKA PIERWSZEJ
 352 C       INSTRUKCJI ZASTEPUJE W PROTOTYPIE ADRES POCZATKU KODU DLA MODULU
 353 C       PRZEZ NUMER REKORDU I MIEJSCE W REKORDZIE ZAWIERAJACE TEN ZNACZNIK.
 354 C
 355 C
 356 C
 357 C     ##### OUTPUT CODE :    15 , 23 , 31 , 33 , 34 , 35 , 36 , 41 ,
 358 C                            85 , 132 , 145 , 149 , 151 , 152 ,
 359 C                            172 , 173 , 176 , 177 , 178 , 179 ,
 360 C                            181 , 182 , 186 , 187 .
 361 C
 362 C
 363 C     ##### DETECTED ERROR(S) :   407 , 410 , 411 , 414 , 415 , 416 ,
 364 C                     418 , 420 , 421 , 422 , 423 , 424 , 426 , 427 ,
 365 C                     428 , 429 , 430 , 440 , 444 , 449 , 454 , 604 .
 366 C
 367 C
 368 #include "stos.h"
 369 #include "option.h"
 370 #include "blank.h"
 371 C
 372 C            STACK - STOS DLA ANALIZY SEMANTYCZNEJ. OD LEWEJ WKLADANE SA
 373 C                    ELEMENTY,OD PRAWEJ OPISY PARAMETROW OUTPUT.
 374 C                    KAZDY ELEMENT STOSU ZAJMUJE KILKA KOLEJNYCH SLOW
 375 C                    OZNACZANYCH -9,...,-1,0. ZEROWE SLOWO OKRESLA RODZAJ
 376 C                    ELEMENTU.
 377 C                      OPISY PAR. OUTPUT ZAJMUJA ZAWSZE 12 SLOW: -9,..,+2
 378 C                    STOS /400 SLOW + WARTOWNIK/ ZAJMUJE W TABLICY IPMEM
 379 C                    SLOWA OD BOTTOM = LMEM-916 DO LMEM-516
 380 C                    ELEMENTY STOSU :
 381 C                                   0 - UNIWERSALNY
 382 C                                   1 - STALA
 383 C                                   2 - WARTOSC
 384 C                                   3 - ZMIENNA
 385 C                                   4 - ELEMENT TABLICY DYN.
 386 C                                   5 - TABLICA STATYCZNA
 387 C                                   6 - OPIS PETLI "FOR"
 388 C                                   7 - NAZWA TYPU
 389 C                                   8 - REKORD
 390 C                                   9 - KLASA
 391 C                                  10 - BLOK PREFIKSOWANY
 392 C                                  11 - PROCEDURA
 393 C                                  12 - FUNKCJA
 394 C                                  13 - SYGNAL
 395 C                                  14 - OPERATOR
 396 C            BOTTOM - WSKAZUJE DNO STOSU / WARTOWNIKA = -1 /
 397 C            VALTOP - CZUBEK STOSU /INDEKS ZEROWEGO SLOWA/
 398 C            VLPREV - INDEKS ZEROWEGO SLOWA POPRZEDNIEGO ELEMENTU
 399 C            STCKAG,STCKA0,STCKAP - TABLICA  -1..14 APETYTOW ELEMENTOW STOSU
 400 C                           /TZN. STCKAP(I)=APETYT ELEMENTU TYPU I/
 401 C                     STCKAP(-1)= 0 =APETYT WARTOWNIKA DLA POP
 402 C            APETYT - TABLICA OKRESLAJACA DLA KAZDEGO RODZAJU TYPU JEGO
 403 C                      APETYT.  1,2,3,4 --> 1,2,3,2
 404 C            LSTFOR - INDEKS OSTATNIEGO SLOWA ZAJETEGO PRZEZ PETLE FOR
 405 C            LSTLSE -   "        "      LSE NA STOSIE /LSE ,TZN. LEWE STRONY
 406 C                     PODSTAWIENIA SA UMIESZCZONE POWYZEJ LSTFOR DO LSTLSE/
 407 C            KIND - RODZAJ WOLANEGO MODULU: 0-ZWYKLY,1-VIRTUALNY,2-FORMALNY
 408 C            PHADR - ATS ADRESU FIZYCZNEGO POLA DANYCH GENEROWANEGO OBIEKTU
 409 C                     LUB 0 ,GDY  ADR.FIZYCZNY TRZEBA ODTWORZYC Z ADR.VIRT.
 410 C            LASTPR - JESLI NA STOSIE JEST FUNKCJA,PROCEDURA,KLASA,REKORD,
 411 C                     SYGNAL,BLOK PREF. , DLA KTOREGO PAMIETANY JEST TYLKO
 412 C                     ADRES POSREDNI ZAMIAST PELNEGO ADR.VIRTUALNEGO, TO
 413 C                     LASTPR= INDEKS TEGO ELEMENTU; INACZEJ ZERO
 414 C            FSTOUT - INDEKS PIERWSZEGO SLOWA ZAJETEGO PRZEZ OPISY PAR.
 415 C                     OUTPUT
 416 C            WB     - BIEZACY SYMBOL /WEJSCIOWY/ KODU POSREDNIEGO
 417 C            RESULT - ATS WYNIKU OPERACJI
 418 C            CONSNR -     TABLICA ZAWIERAJACA ADRESY /INDEKSY W IPMEM/ TYPOW:
 419 C                BOOLEAN,CHAR,INTEGER,NONE,REAL,STRING I UNIWERSALNEGO .
 420 C            LSTSAF - OSTATNI ELEMENT STOSU NIE WYMAGAJACY ZABEZPIECZENIA
 421 C                      PRZEZ SAFEST ,USTAWIA SAFEST,OBNIZA SPOP.
 422 C            TEMPNR - POCZATEK ADRESOW W /BUDOWANEJ/ TABLICY SYMBOLI
 423 C                      UZYWANYCH DLA ATRYBUTOW ROBOCZYCH,
 424 C                      ADRESY WIEKSZE ZAREZERWOWANE DLA PETLI FOR,
 425 C                       ZMNIEJSZANE O 6 NA POCZATKU, A ZWIEKSZANE NA KONCU
 426 C                       PETLI.
 427 C            LSTEMP - NAJMNIEJSZY UZYTY ADRES ATRYBUTU ROBOCZEGO
 428 C
 429 C            QRECNR - OSTATNI UZYTY NUMER REKORDU W STRUMIENIU 3
 430 C                  BUFOR NA GENEROWANY KOD POSREDNI WYSYLANY NA STRUMIEN 3
 431 C                  ZAJMUJE 259 SLOW W TABLICY IPMEM : OD LMEM-259 DO LMEM-1 .
 432 C            LSTWRD - INDEKS OSTATNIEGO ZAJETEGO SLOWA W BUFORZE.
 433 C
 434 C                ZASADA WYPELNIANIA BUFORA : SA CO NAJMNIEJ 4 WOLNE SLOWA
 435 C                / LSTWRD < LMEM-4 / . PROCEDURY QUADR1 .. QUADR4
 436 C                 DOPISUJA ZA LSTWRD SWOJE ARGUMENTY I ZWIEKSZAJA LSTWRD.
 437 C                 JESLI POZOSTANA MNIEJ NIZ 4 SLOWA - WOLAJA QDROUT.
 438 C                QDROUT WYPISUJE PIERWSZE 256 SLOW I OSTATNIE 3 SLOWA
 439 C                PRZEPISUJE NA POCZATEK, ZMNIEJSZAJAC LSTWRD O 256.
 440 C            FRSTTS - PIERWSZE SLOWO W IPMEM NA NOWE OPISY ATRYBUTOW
 441 C                       W TABLICY SYMBOLI
 442 C               ZAPELNIANIE TABLICY SYMBOLI: TSINSE -->  <-- TSTEMP
 443 C                      OBSZAR WOLNY -   FRSTTS .. LSTEMP-1
 444 C            UNIT - RODZAJ BIEZACEGO MODULU:
 445 C                               1 - BLOK
 446 C                               2 - HANDLER
 447 C                               3 - BLOK PREFIKSOWANY
 448 C                               4 - PROCEDURA
 449 C                               5 - FUNKCJA
 450 C                               6 - KLASA
 451 C            INNER = 0 - NIE BYLO "INNER",ALE JEST LEGALNY
 452 C                    1 - WYSTAPIENIE "INNER" BEDZIE NIELEGALNE
 453 C                    2 - JUZ WYSTAPIL
 454 C                    4 - LAST-WILL  WYSTAPIENIE INNER NIELEGALNE
 455 C            LSTWILL - TRUE,JESLI WYSTAPILO LAST WILL
 456 C
 457 C            TEST - OPCJA / U3 / WYDRUKOW KONTROLNYCH ,
 458 C                     = 0 --> BEZ WYDRUKOW , <> 0 --> WYDRUKI
 459 C
 460 C            ARG - INFORMACJA O STALYCH ARGUMENTACH /USTAWIANA PRZEZ
 461 C                   SARGMT/  :
 462 C                           1 - OBA STALE
 463 C                           2 - LEWY STALY,PRAWY NIE
 464 C                           3 - LEWY NIE,PRAWY STALY
 465 C                           4 - OBA ROZNE OD STALYCH
 466 C            ATLINE - NUMER LINII, W KTOREJ PRZEBIEG MA SIE ZAWIESIC
 467 C
 468 C            FILE - ADRES PLIKU NA STOSIE LUB 0 DLA OPERACJI NA PLIKU
 469 C                    STANDARDOWYM
 470 C
 471 C            FLARGS - INFORMACJA O PRZETWORZONYCH ARGUMENTACH OPERACJI
 472 C                      WE/WY :
 473 C                       0 - NIE WYSTAPIL ZADEN ARGUMENT
 474 C                       1 - WYSTAPIL TYLKO ADRES PLIKU
 475 C                       2 - WYSTAPIL CO NAJMNIEJ 1 ARGUMENT
 476 C                            ( LUB READLN/WRITELN )
 477 C
 478 C            FLREADY - TRUE, JESLI (R6-12) ZAWIERA ADRES PLIKU, ZAPALANE PRZEZ
 479 C                       SFLADR, GASZONE PRZEZ SCALLB I DLA 'I-O-END'
 480 C
 481 C            FLMODF - PRZELACZNIK NUMERU PROCEDURY STANDARDOWEJ UZYWANY
 482 C                      DLA WE/WY :  1 DLA PLIKU STANDARDOWEGO
 483 C                                   0 DLA WSKAZYWANEGO
 484 C                     NUMERY PROCEDUR WE/WY (ROZNE PUNKTY WEJSCIA) SA
 485 C                      POWIAZANE :
 486 C                            INPUT      : N-1
 487 C                            WSKAZYWANY : N
 488 C                            OUTPUT     : N+1
 489 C
 490 C.............
 491 C   COMDECK OPT?      04.01.84
 492 C     COMMON/OPTION/OPTMEM,OPTOPT,OPTIND,OPTTYP,OPTTRC,OPTCSC,OPTCSF
 493 C     LOGICAL OPTOPT,OPTTYP,OPTTRC
 494 C   FROM LOGLAN.08
 495 C
 496 C          ***** OPCJE KOMPILATORA *****
 497 C
 498 C            OPTMEM -       0 - TRZEBA ROBIC MEMBER
 499 C                           1 - NIE TRZEBA ROBIC MEMBER
 500 C            OPTOPT -     .TRUE. - WOLNO OPTYMALIZOWAC
 501 C                         .FALSE. - NIE WOLNO
 502 C            OPTIND -       0 - KONTROLA INDEKSOW DLA TABLIC
 503 C                           2 - BEZ KONTROLI INDEKSOW
 504 C            OPTTYP -      .TRUE. - BEZ DYNAMICZNEJ KONTROLI TYPOW
 505 C
 506 C            OPTTRC -      .TRUE. - KOMPILAT POWINIEN ZAWIERAC SLEDZENIE
 507 C
 508 C            OPTCSC -         1   - BEZ KONTROLI ZAKRESU DLA "CASE"
 509 C                             0     WYMAGANA KONTROLA
 510 C            OPTCSF -         0   - SZYBKI "CASE"
 511 C                             1   - PAMIECIOOSZCZEDNY
 512 C
 513 C
 514 C................
 515 C
 516 C*COMDECK BLANKSEM
 517 C     LOGICAL   INSYS,  OWN
 518 C     COMMON /BLANK/ IOP(4),
 519 C    X        P,
 520 C    X        TLDIM, TLBAS,  IDL, OBJL,
 521 C    X        TRDIM, TRBAS,  IDR, OBJR,
 522 C    X        TRESLT,
 523 C    X        TRESLT,
 524 C    X        CONVL, CONVR,
 525 C    X        NRPAR,
 526 C    X        IX (261),
 527 C    X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 528 C    X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 529 C    X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 530 C    X        LOCAL,  OWN,    OBJECT,
 531 C    X        IPMEM(5000)
 532 C     REAL   STALER(100)
 533 C     INTEGER STACK(5000)
 534 C     EQUIVALENCE(STALER(1),IPMEM(1))
 535 C     EQUIVALENCE(STACK(1),IPMEM(1))
 536 C......COMDECK BLANKSEM
 537 C      FROM LOGLAN.08      17.01.84
 538 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
 539 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  IPMEM
 540 C
 541 C     CZESC SEMANT
 542 C             P - PROTOTYP AKTUALNY
 543 C             TLDIM - LICZBA ARRAY OF W TYPIE LEWEGO ARGUMENTU
 544 C             TLBAS - TYP BAZOWY LEWEGO ARGUMENTU
 545 C             DISPL - .TRUE. JESLI LEWY ARGUMENT JEST DOSTEPNY  PRZEZ
 546 C                  DISPLAY
 547 C            OBJL - PROTOTYP OBIEKTU, Z KTOEGO POCHODZI TEN ATRYBUT
 548 C             IDL - IDENTYFIKATOR LEWEGO ARGUMENTU (DO SYGNALIZACJI BLE-
 549 C                   DOW)
 550 C             TRDIM, TRBAS, DISPR, IDR, OBJR - ANALOGICZNIE DLA PRAWEGO ARGU-
 551 C                   MENTU
 552 C             TRESLT - TYP BAZOWY WYNIKU OPERACJI ARYTMETYCZNEJ
 553 C             CONVL, CONVR - FLAGA KONWERSJI LEWEGO I PRAWEGO ARGUMENTU
 554 C                   OPERACJI ARYTMETYCZNYCH LUB RELACJI
 555 C                   WARTOSCI :
 556 C                     0 - BRAK KONWERSJI
 557 C                     1 - KONWERSJA DO REAL
 558 C                     2 - KONWERSJA DO INTEGER (?)
 559 C             NRPAR - NUMER PARAMETRU (PROCEDURA  MPKIND)
 560 C
 561 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
 562 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
 563 C
 564 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
 565 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
 566 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
 567 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
 568 C
 569 C     IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
 570 C             NRINT  - IDENTYFIKATOR PROTOTYPU  INTEGER
 571 C             NRRE   -                          REAL
 572 C             NRBOOL -                          BOOLEAN
 573 C             NRCHR  -                          CHARACTER
 574 C             NRCOR  -                          COROUTINE
 575 C             NRPROC -                          PROCESS
 576 C             NRTEXT -                          STRING (TEXT)
 577 C             NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
 578 C             NATTR  - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
 579 C             NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
 580 C                      REFERENCYJNY)
 581 C             NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
 582 C             NBLUS  -               BLOKU GLOWNEGO UZYTKOWNIKA
 583 C
 584 C             INSYS  - FLAGA SPOSOBU REZERWACJI (PRZEZ  MGETM) PAMIECI
 585 C                      W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
 586 C                      MOWEJ
 587 C             LOCAL  - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT
 588 C                      BYL LOKALNY
 589 C             OWN    - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
 590 C                      POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
 591 C             OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
 592 C                     SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
 593 C
 594 C
 595       COMMON/STREAM/ ERRFLG,LINE,IBUF23(272),JUNK(260)
 596       LOGICAL ERRFLG
 597       LOGICAL MLOCTP,MDISTP
 598 C
 599 C
 600       COMMON/TEST/TESTC,TESTS,TESTH
 601       LOGICAL TESTC,TESTS,TESTH
 602 cdsw&bc
 603       real y
 604       integer*2 m(2)
 605       equivalence (y, m(1))
 606 cdsw&bc
 607       common /stacks/ btsins, btstem
 608 C
 609 C
 610       LOGICAL INICJA
 611 C     INICJA=.TRUE. W FAZIE WYLICZANIA WARTOSCI STALYCH SYMBOLICZNYCH I GRANIC
 612 C     TABLIC STATYCZNYCH.
 613 C
 614 C
 615 C
 616       INTEGER ERROR
 617 C     ERROR=NUMER BLEDU DLA WSPOLNEJ SYGNALIZACJI /9900/
 618 C
 619       LOGICAL FORSTP
 620 C     DLA PETLI "FOR" : TRUE --> WYSTAPILO "STEP", FALSE --> NIE WYSTAPILO
 621 C
 622 C
 623 C
 624 C     AUXILIARY VARIABLES
 625       INTEGER ATS,ELEM,I,IND
 626 C
 627 C.....INICJALIZACJA
 628 cdsw&bc      FRSTTS=LPMEM+1
 629       frstts = btsins
 630 c
 631 C     =INDEKS POCZATKU TABLICY SYMBOLI - CZESC DLA ATRYBUTOW DEKLAROWANYCH
 632       IPMEM(LMEM)=BOTTOM-1
 633 C     OSTATNIE SLOWO IPMEM ZAWIERA INDEKS PIERWSZEGO OD PRAWEJ WOLNEGO
 634 C     SLOWA NA POMOCNICZY SLOWNIK DLA WYZNACZANIA ADRESOW ATRYBUTOW
 635 C     DEKLAROWANYCH W TABLICY SYMBOLI.
 636 C
 637 C
 638 C
 639       CONSNR(1)=NRBOOL
 640       CONSNR(2)=NRCHR
 641       CONSNR(3)=NRINT
 642       CONSNR(4)=NRNONE
 643       CONSNR(5)=NRRE
 644       CONSNR(6)=NRTEXT
 645       CONSNR(7)=NRUNIV
 646 cdsw&bc
 647       consnr(8)=-17
 648       IF(INICJA)GO TO 10
 649       CALL SINIT
 650    10 VALTOP=BOTTOM
 651       VLPREV=BOTTOM
 652       LSTLSE=BOTTOM
 653       LSTFOR=BOTTOM
 654       LASTPR=0
 655       LSTSAF=BOTTOM
 656       FSTOUT=BOTTOM+401
 657 cdsw&bc      TEMPNR=LMEM-6
 658       tempnr = btstem-6
 659 c
 660       LSTEMP=TEMPNR
 661       FILE=0
 662       FLARGS=0
 663       FLREADY=.FALSE.
 664       FLMODF=1
 665       ICOUNT=0
 666       OCOUNT=0
 667       GO TO 50
 668 C
 669 C
 670 C
 671    30 CALL SPOP
 672    40 CALL SNEXT
 673 C.....GLOWNA PETLA.  W ZALEZNOSCI OD SYMBOLU Z WEJSCIA WYBIERZ AKCJE
 674    50 CONTINUE
 675       GO TO(100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,
 676      X 1400,1500,1600,1700,1800,1900,2000,2100,2200,2300,2400,2500,
 677      X 2600,2700,2800,2900,3000,3100,3200,3300,3400,3500,3600,3700,
 678      X 3800,3900,4000,4100,4200,4300,4400,4500,4600,4700,4800,4900,
 679      X 5000,5100,5200,5300,5400,5500,5600,5700,5800,5900,6000,6100,
 680      X 6200,6300,6400,6500,6600,6700,6800,6900,7000,7100,7200,7300,
 681      X 7400,7500,7600,7700,7800,7900,8000,8100,8200,8300,8400,8500,
 682      X 8600,8700,8800,8900,9000,9100,9200,9300,9400),WB
 683 cbc  X 8600,8700,8800,8900,9000),WB
 684 cbc  X 8600,8700,8800),WB
 685 C
 686 C----------------  AND    --------------------------
 687 C
 688   100 CALL SBOOLEX(1)
 689       GO TO 40
 690 C
 691 C---------------  ARRAY OF  ------------------------
 692 C
 693 C     ZWRACA : SLOWO -2 =0  - TYP STATYCZNY (-3),(-4)
 694 C              SLOWO -2 >0 - ATS ZMODYFIKOWANEGO TYPU FORMALNEGO
 695 C
 696   200 CALL SNEXT
 697 C      WB=LICZBA ARRAY OF
 698 C     CZY NA CZUBKU JEST KLASA,REKORD LUB NAZWA TYPU?
 699       ELEM=STACK(VALTOP)
 700       IF(ELEM.EQ.0)GO TO 40
 701       IF(ELEM.LT.7 .OR. ELEM.GT.9)GO TO 250
 702 C     OK. WPISZ LICZBE ARRAY OF
 703       STACK(VALTOP-3)=WB
 704 C     CZY TYP FORMALNY?
 705       IF(STACK(VALTOP-2).NE.0) CALL SMODIFY(STACK(VALTOP-2),WB)
 706       GO TO 40
 707 C.....NIEPOPRAWNY CZUBEK STOSU
 708   250 ERROR=440
 709       GO TO 9900
 710 C
 711 C---------------  ASSIGN  --------------------------
 712 C
 713 C     CZUBEK STOSU POWINIEN ZAWIERAC WARTOSC,PONIZEJ SA LSE /POWYZEJ LSTFOR DO
 714 C
 715   300 CALL SASSIGN
 716       GO TO 40
 717 C
 718 C---------------  ASSIGN CONST  --------------------
 719 C     CZUBEK STOSU POWINIEN ZAWIERAC STALA /WARTOSC WYRAZENIA DEFINIUJACEGO/,
 720 C     PONIZEJ CZUBKA JEST STALA DEFINIOWANA,MAJACA W SLOWIE -2 INDEKS
 721 C     SWOJEGO OPISU W IPMEM.
 722 C
 723 C     STALA?
 724   400 IF(STACK(VLPREV).EQ.0 .OR. STACK(VALTOP).EQ.0)GO TO 420
 725       IF(STACK(VALTOP).EQ.1)GO TO 410
 726       CALL SERRO2(429,VLPREV)
 727       GO TO 420
 728 C     POBIERZ ADRES OPISU STALEJ DEFINIOWANEJ
 729   410 ELEM=STACK(VLPREV-2)
 730 C     WPISZ WARTOSC I TYP
 731       IPMEM(ELEM-1)=STACK(VALTOP-2)
 732       IPMEM(ELEM-4)=0
 733       IPMEM(ELEM-3)=STACK(VALTOP-4)
 734   420 CALL SPOP
 735       GO TO 30
 736 C
 737 C---------------  ATTACH  --------------------------
 738 C     CZUBEK STOSU POWINIEN ZAWIERAC REFERENCJE
 739 C
 740   500 CALL SATTACH
 741       LSTEMP=TEMPNR
 742       GO TO 30
 743 C
 744 C---------------  BLOCK  ---------------------------
 745 C      WYSTAPIENIE BLOKU O NUMERZE WN
 746   600 CALL SNEXT
 747       CALL QUADR2(186,IPMEM(WB))
 748       LSTEMP=TEMPNR
 749       GO TO 40
 750 C
 751 C---------------  CALL  ----------------------------
 752 C     NA PEWNO BLAD: PROCEDURA SAMA "ZJADA" CALL.
 753 C
 754   700 CALL SERROR(422)
 755       GO TO 30
 756 C
 757 C---------------  CASE  ----------------------------
 758   800 CALL SCASE
 759       GO TO 30
 760 C     WRACA DO ETYKIETY 30
 761 C---------------  CASE LABEL  ----------------------
 762   900 CALL SCSLAB
 763       GO TO 30
 764 C     WRACA DO ETYKIETY 30
 765 C---------------  COMA  ----------------------------
 766 C
 767 C     PONIZEJ CZUBKA JEST :
 768 C        UNIWERSALNY LUB ELEMENT TABLICY/DYN./ LUB TABLICA STATYCZNA
 769 C         LUB REKORD,KLASA,BLOK PREF.,PROCEDURA,FUNKCJA.
 770 C     NA CZUBKU JEST INDEKS LUB PARAMETR AKTUALNY.
 771 C     PO OBSLUZENIU  WOLA SNEXT
 772 C
 773  1000 ELEM=STACK(VLPREV)
 774 C     JESLI UNIWERSALNY-OMIN
 775       IF(ELEM.EQ.0)GO TO 30
 776 C     CZY TO PARAMETR?
 777       IF(ELEM.GT.7)GO TO 1050
 778 C     NIE,MOZE TABLICA STATYCZNA?
 779       IF(ELEM.EQ.5)GO TO 1060
 780 C     ZATEM TABLICA DYNAMICZNA /ELEMENT TABLICY/
 781       CALL SINDEX
 782       GO TO 30
 783  1050 CALL SPARAM
 784       GO TO 40
 785  1060 CALL SINDXS
 786       GO TO 40
 787 C
 788 C---------------  CONST:BOOL,CHAR,INT,NONE,REAL,STRING  -----
 789 C
 790  1100 CONTINUE
 791  1200 CONTINUE
 792  1300 CONTINUE
 793  1500 CONTINUE
 794  1600 ELEM=WB-10
 795       CALL SNEXT
 796 C.....WSPOLNA AKCJA DLA WSZYSTKICH STALYCH,ROWNIEZ NONE
 797  1650 CALL SPUSH(1)
 798       STACK(VALTOP-1)=0
 799       STACK(VALTOP-2)=WB
 800       STACK(VALTOP-3)=0
 801       STACK(VALTOP-4)=CONSNR(ELEM)
 802       STACK(VALTOP-5)=0
 803       GO TO 40
 804 C.....WYROZNIONY POCZATEK DLA NONE
 805  1400 ELEM=4
 806       WB=0
 807       GO TO 1650
 808 C
 809 C
 810 C---------------  COPY  ----------------------------
 811 C     NA CZUBKU STOSU JEST WARTOSC DO SKOPIOWANIA.
 812 C
 813  1700 CALL SVALUE
 814 C     JESLI UNIWERSALNY-POMIN
 815       IF(STACK(VALTOP).EQ.0)GO TO 40
 816 C     ZBADAJ TYP. POMIN NONE.
 817       ELEM=STACK(VALTOP-4)
 818       IF( ELEM.EQ.NRNONE)  GO TO 40
 819 C     MOZE TO TABLICA?
 820       IF(STACK(VALTOP-3).GT.0)GO TO 1750
 821 C     NIE. CZY TYP PIERWOTNY?
 822       DO 1730 I=1,6
 823       IF(CONSNR(I).EQ.ELEM)GO TO 1790
 824  1730 CONTINUE
 825 C.....ZATEM O.K.
 826  1750 ATS=TSTEMP(4)
 827       CALL QUADR3(41,ATS,STACK(VALTOP-2))
 828       STACK(VALTOP)=2
 829       STACK(VALTOP-2)=ATS
 830       GO TO 40
 831 C.....NIE REFERENCJA
 832  1790 ERROR=415
 833       GO TO 9900
 834 C
 835 C---------------  DETACH  --------------------------
 836 C
 837  1800 CALL QUADR1(187)
 838       LSTEMP=TEMPNR
 839       GO TO 40
 840 C
 841 C---------------  DOT ------------------------------
 842 C
 843  1900 CALL SNEXT
 844 C     WB=IDENT
 845       CALL SNEXT
 846 C     WB = NAZWA PO KROPCE
 847       CALL SVALUE
 848       IF(STACK(VALTOP).NE.0)GO TO 1910
 849 C     UNIWERSALNY.IDENT ZASTAP PRZEZ UNIWERSALNY Z NAZWA PO KROPCE
 850       STACK(VALTOP-1)=WB
 851       GO TO 40
 852 C     O.K.
 853  1910 I=STACK(VALTOP-4)
 854 C     I=KWALIFIKACJA WARTOSCI PRZED KROPKA
 855       IND=MDOT(STACK(VALTOP-3),I,STACK(VALTOP-1),WB)
 856       ATS=STACK(VALTOP-2)
 857 C     ATS=WARTOSC PRZED KROPKA
 858       CALL SPOP
 859 C     DALEJ JAK DLA WIDOCZNEGO IDENTYFIKATORA
 860       GO TO 2805
 861 C---------------  DOWNTO  --------------------------
 862  2000 CALL SFORTO(.FALSE.,FORSTP)
 863       GO TO 40
 864 C     POWROT DO ETYKIETY 40
 865 C---------------  SIGN  ----------------------------
 866  2100 CALL SVALUE
 867       ELEM=STACK(VALTOP)
 868       IDL=STACK(VALTOP-2)
 869       IF(ELEM.EQ.0)GO TO 40
 870       IF(STACK(VALTOP-3).GT.0)GO TO 2110
 871       ATS= +1
 872       IF(STACK(VALTOP-4).EQ.NRINT)GO TO 2130
 873       IF(STACK(VALTOP-4).EQ.NRRE)GO TO 2150
 874 C ... NIEPOPRAWNY TYP ARGUMENTU SIGN
 875  2110 ERROR=604
 876       GO TO 9900
 877 C ... INTEGER.   STALA ?
 878  2130 IF(ELEM.NE.1)GO TO 2160
 879       IF(IDL.LT.0) ATS= -1
 880       IF(IDL.EQ.0) ATS= 0
 881       GO TO 2170
 882 C ... REAL.      STALA ?
 883  2150 IF(ELEM.NE.1)GO TO 2160
 884 cdsw&bc      IF(STALER(IDL).LT. 0.0) ATS= -1
 885 cdsw&bc      IF(STALER(IDL).EQ. 0.0) ATS= 0
 886 #if WSIZE == 4
 887       if(staler(idl) .lt. 0.0) ats= -1
 888       if(staler(idl) .eq. 0.0) ats= 0
 889 #else
 890       n1 = idl*2-1
 891       m(1) = ipmem(n1)
 892       m(2) = ipmem(n1+1)
 893       if(y .lt. 0.0) ats= -1
 894       if(y .eq. 0.0) ats= 0
 895 #endif
 896 c
 897       GO TO 2170
 898 C ... GENERUJ KOD
 899  2160 ATS=TSTEMP(1)
 900       CALL QUADR3(31,ATS,IDL)
 901 C     ZASTAP PRZEZ WARTOSC
 902       STACK(VALTOP)=2
 903  2170 STACK(VALTOP-1)=0
 904       STACK(VALTOP-2)=ATS
 905       STACK(VALTOP-4)=NRINT
 906       GO TO 40
 907 C---------------  ESAC  ----------------------------
 908  2200 CALL SESAC
 909       GO TO 40
 910 C---------------  FIN  -----------------------------
 911 C
 912  2300 CALL SEND
 913       RETURN
 914 C
 915 C
 916 C---------------  FIRSTINSTR  ----------------------
 917 C
 918 C     JESLI TO FAZA WYLICZANIA STALYCH - ZAPAMIETAJ TO MIEJSCE I KONCZ.
 919 C
 920  2400 IF(INICJA)GO TO 2450
 921       CALL SNEXT
 922 C     PIERWSZA INSTRUKCJA MODULU, WB=NUMER INSTRUKCJI
 923       CALL QUADR1(179)
 924       LINE=WB
 925       GO TO 40
 926 C
 927 C ... KONIEC WYLICZANIA STALYCH DLA TEGO MODULU
 928  2450 IPMEM(P+8)=IX(258)
 929       IPMEM(P+9)=IX(257)
 930       RETURN
 931 C---------------  FOR END  -------------------------
 932 C
 933  2500 CALL SFOREND
 934       GO TO 30
 935 C     POWROT DO ETYKIETY 30
 936 C---------------  FOR VARIABLE  --------------------
 937 C
 938 C     PISZ : KONIEC BLOKU BAZOWEGO /BY UNIKNAC PONOWNEGO PRZYDZIALU
 939 C         TYCH SAMYCH ATRYBUTOW ROBOCZYCH W JEDNYM BLOKU/
 940  2600 CALL QUADR1(176)
 941 C     ZAREZERWUJ 2 NUMERY DLA ATRYBUTOW ROBOCZYCH DLA PETLI FOR
 942       TEMPNR=TEMPNR-6
 943       IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
 944 C
 945 C
 946       LSTEMP=TEMPNR
 947 C
 948 C
 949 C ... ZMIENNA PROSTA?
 950       IND=STACK(VALTOP)
 951       IF(IND.EQ.0)GO TO 40
 952       ERROR=410
 953 C     ="OCZEKIWANA ZMIENNA PROSTA"
 954       IF(IND.NE.3 .OR. STACK(VALTOP-7).NE.0)GO TO 9900
 955 C     TAK. INTEGER?
 956       CALL SCHECK(411,NRINT)
 957       LSTLSE=VALTOP
 958       GO TO 40
 959 C---------------  FROM  ----------------------------
 960 C
 961  2700 CALL SINDTYP
 962       FORSTP=.FALSE.
 963       GO TO 40
 964 C---------------  IDENTYFIKATOR  -------------------
 965 C     WB=IDENT , WN=NAZWA ZE SCANNERA
 966  2800 CALL SNEXT
 967       IND=MIDENT(WB)
 968       ATS=0
 969 C..........WSPOLNE ROZPOZNANIE I OBSLUGA DLA IDENTYFIKATORA PRZEZ KROPKE
 970 C     LUB WIDOCZNEGO.
 971 C     IND = ADRES ZEROWEGO SLOWA OPISU ROZPOZNANEGO IDENTYFIKATORA
 972 C     ATS= ATS WARTOSCI PRZED KROPKA /I=KWALIFIKACJA/ LUB ZERO
 973 C
 974  2805 ELEM=SWHAT(IND)
 975 C     WLOZ NA STOS , WPISZ NAZWE , WEZ KOLEJNY SYMBOL
 976       CALL SPUSH(ELEM)
 977       STACK(VALTOP-1)=WB
 978       CALL SNEXT
 979 C     FAZA WYLICZANIA STALYCH ?
 980       IF(INICJA)GO TO 2850
 981 C     NIE.
 982 C     JESLI TO "UNIWERSALNY"-NIC NIE ROB
 983       IF(ELEM.EQ.0)GO TO 50
 984  2807 STACK(VALTOP-6)=0
 985       STACK(VALTOP-7)=ATS
 986       STACK(VALTOP-5)=0
 987 C     NAZWA TYPU?
 988       IF(ELEM.EQ.7)GO TO 2880
 989       IF(ELEM.GT.5)GO TO 2870
 990 C.....STALA,ZMIENNA,TABLICA STATYCZNA. WSTAW TYP.
 991       STACK(VALTOP-4)=IPMEM(IND-3)
 992 C     STALA?
 993       IF(ELEM.NE.1)GO TO 2815
 994 C....."STALA"
 995       STACK(VALTOP-3)=0
 996       IF(.NOT.INICJA)STACK(VALTOP-2)=IPMEM(IND-1)
 997 C     WSTAWIONY TYP,WARTOSC STALEJ
 998       GO TO 50
 999 C....."ZMIENNA","TABLICA STATYCZNA"
1000  2815 STACK(VALTOP-3)=IPMEM(IND-4)
1001       STACK(VALTOP-2)=IND
1002       IF(ATS.EQ.0)STACK(VALTOP-2)=TSINSE(IND,LOCAL)
1003 C     WSTAWIONY ATS
1004 C.....TYPU FORMALNEGO?
1005       ELEM=STACK(VALTOP-4)
1006  2820 ELEM=IAND(IPMEM(ELEM),15)
1007 C     ELEM=POLE T TYPU ZMIENNEJ
1008       IF(ELEM.NE.6)GO TO 2830
1009 C     A WIEC TYP FORMALNY. PRZEZ KROPKE?
1010       IF(ATS.NE.0)GO TO 2825
1011 C.....PRZEZ DISPLAY
1012       STACK(VALTOP-6)=OBJECT
1013 C     CZY TYP DOSTEPNY PRZEZ DISPLAY?
1014       IF(MDISTP(IPMEM(IND-1),STACK(VALTOP-4),ELEM))GO TO 2823
1015 C     TYP NIEDOSTEPNY PRZEZ DISPLAY,WSTAW SL ZMIENNEJ
1016       STACK(VALTOP-5)= - IPMEM(IND-1)
1017       GO TO 2830
1018 C     TYP DOSTEPNY PRZEZ DISPLAY,WSTAW WARSTWE
1019  2823 STACK(VALTOP-5)=ELEM
1020       GO TO 2830
1021 C.....PRZEZ KROPKE. TYP JEST LOKALNYM ATRYBUTEM?
1022  2825 STACK(VALTOP-5)= -1
1023       IF(MLOCTP(STACK(VALTOP-4),I))STACK(VALTOP-5)= +1
1024 C.....TYP JUZ WSTAWIONY
1025  2830 IF(STACK(VALTOP).EQ.3)GO TO 50
1026       IF(STACK(VALTOP).EQ.12)GO TO 2875
1027 C....."TABLICA STATYCZNA"
1028       CONTINUE
1029 C      NA RAZIE  B R A K
1030       GO TO 50
1031 C
1032 C ... W FAZIE WYLICZANIA STALYCH
1033  2850 IF(ELEM.LT.2)GO TO 2860
1034 C     NIELEGALNY OBIEKT W WYRAZENIU DEFINIUJACYM STALA.
1035       ERROR=429
1036       GO TO 9901
1037  2860 IF(ELEM.EQ.0)GO TO 50
1038 C     STALA DEFINIOWANA ? /TAK,JESLI  WB = "LSE" /
1039       IF(WB.NE.39)GO TO 2865
1040 C     TAK. WSTAW DO SLOWA -2 ADRES OPISU STALEJ
1041       STACK(VALTOP-2)=IND
1042       GO TO 50
1043 C     STALA W WYRAZENIU DEFINIUJACYM. WSTAW DO SLOWA -2 WARTOSC
1044 C         / DLA REAL - NUMER STALEJ /
1045  2865 STACK(VALTOP-2)=IPMEM(IND-1)
1046 C     CZY STALA MA JUZ OKRESLONA WARTOSC ?
1047       IF(IPMEM(IND-3).NE.0)GO TO 2807
1048 C      TYP = 0  /SLOWO -3/ OZNACZA,ZE STALA JESZCZE NIE MIALA OKRESLONEJ
1049 C        WARTOSCI
1050       ERROR=430
1051       GO TO 9901
1052 C
1053 C.....REKORD,KLASA,PROCEDURA,FUNKCJA,SYGNAL,OPERATOR.
1054  2870 ELEM=IPMEM(IND-3)
1055       STACK(VALTOP-4)=IND
1056       STACK(VALTOP-3)=0
1057       IDR=STACK(VALTOP)-7
1058 C     DLA FUNKCJI ZBADAJ CZY TYP FORMALNY
1059       GO TO (2872,2872,2872,2875,2820,2875,2890),IDR
1060 C
1061 C ... KLASA,REKORD .  NEW ?
1062  2872 STACK(VALTOP-2)=0
1063 C     - TYP STATYCZNY
1064       IF(WB.EQ.40)GO TO 2873
1065 C     LEWY NAWIAS?
1066       IF(WB.NE.36)GO TO 50
1067 C     BRAK NEW PRZED LEWYM NAWIASEM
1068       CALL SERROR(423)
1069       GO TO 2874
1070 C     NEW
1071  2873 CALL SNEXT
1072  2874 CALL SCALLB
1073       GO TO 50
1074 C ... PROCEDURA,SYGNAL, C.D. DLA FUNKCJI
1075 C     JESLI WB ROZNE OD "," LUB ")"  - WYWOLAJ /INACZEJ-PODEJRZEWAJ PARAMETR/
1076  2875 IF(WB.NE.10 .AND. WB.NE.54)GO TO 2874
1077       GO TO 50
1078 C....."NAZWA TYPU"  /PARAMETR FORMALNY "TYPE"/
1079  2880 STACK(VALTOP-3)=0
1080       STACK(VALTOP-4)=IND
1081 C     PRZEZ KROPKE?
1082       IF(ATS.NE.0)GO TO 2885
1083 C     PRZEZ DISPLAY
1084       STACK(VALTOP-2)=TSINSE(IND,LOCAL)
1085 C     ZERO ARRAY OF,TYP FORMALNY,ATS TEGO TYPU
1086       STACK(VALTOP-6)=OBJECT
1087       GO TO 50
1088 C.....PARAMETR "TYPE" PRZEZ KROPKE
1089 C     ODCZYTAJ TYP
1090  2885 STACK(VALTOP-2)=TSTEMP(2)
1091       CALL QUADR4(85,STACK(VALTOP-2),SMEMBER(VALTOP),IND)
1092       GO TO 50
1093 C.....OPERATOR, JESLI WB ROZNE OD "(" - BLAD
1094  2890 ERROR=454
1095 C     = NIELEGALNE WYSTAPIENIE NAZWY OPERATORA
1096       IF(WB.NE.36)GO TO 9901
1097       GO TO 50
1098 C--------------- IF-FALSE , IF-TRUE  ----------------
1099  2900 CONTINUE
1100  3000 CALL SVALUE
1101       IND=WB-29
1102 C     IND= 1 DLA IF-TRUE , = 0 DLA IF-FALSE
1103       CALL SNEXT
1104 C     NA CZUBKU WARTOSC TYPU BOOLEAN?
1105       CALL SCHECK(407,NRBOOL)
1106 C     STALA?
1107       IF(STACK(VALTOP).EQ.1)GO TO 3050
1108       CALL QUADR3(151+IND,STACK(VALTOP-2),WB)
1109       GO TO 30
1110 C     SKOK PRZY STALEJ WARTOSCI WYRAZENIA
1111  3050 IF(IND+STACK(VALTOP-2).NE.0) GOTO 30
1112 C       ZATEM TRUE, IF TRUE   FALSE, IF FALSE
1113         CALL SPOP
1114         GOTO 3350
1115 C
1116 C------ INNER --------
1117 C       LOKALNE WYSTAPIENIE
1118 3100    IF (INNER.NE.0) CALL MERR(424+INNER,0)
1119         INNER = 2
1120         CALL QUADR2(178,IPMEM(P+23))
1121 C       ZAZNACZ: INSTRUKCJE PO INNER
1122         IPMEM(P-7) = P
1123         LSTEMP = TEMPNR
1124         GOTO 40
1125 C
1126 C------- INSTREND--------
1127 C
1128 3200    CALL SNEXT
1129         LINE= WB
1130 CJF     IF (LINE.EQ.ATLINE) CALL STOPAT(ATLINE)
1131         CALL SNEXT
1132 C       JESLI BYLY BLEDY CZYSC STOS
1133         IF (ERRFLG) GOTO 10
1134         IF (INICJA) GOTO 50
1135 C
1136 C
1137 C PRZY ZGASZONEJ OPCJI "OPTIMALIZATION" LUB "SYSPP"  ZAKONCZ BLOK BAZOWY
1138       IF(OPTOPT.AND.IPMEM(NBLSYS+4).EQ.0)GO TO 3250
1139       LSTEMP=TEMPNR
1140       CALL QUADR1(176)
1141 C
1142 C     PRZY WYLACZONEJ OPCJI "TRACE" WYPISZ UJEMNY  NUMER
1143  3250 ELEM=LINE
1144       IF(.NOT.OPTTRC)ELEM=-LINE
1145       CALL QUADR2(177,ELEM)
1146       GO TO 50
1147 C---------------  JUMP  -----------------------------------
1148  3300 CALL SNEXT
1149  3350 CALL QUADR2(182,WB)
1150       LSTEMP=TEMPNR
1151       GO TO 40
1152 C---------------  KILL  ----------------------------
1153 C     CZUBEK POWINIEN ZAWIERAC WARTOSC REFERENCYJNA
1154 C
1155  3400 CALL SKILL
1156       GO TO 30
1157 C
1158 C---------------  LABEL  ----------------------------
1159  3500 CALL SNEXT
1160 C     WYPISZ ETYKIETE
1161       CALL QUADR2(181,WB)
1162       LSTEMP=TEMPNR
1163       GO TO 40
1164 C---------------  LEFT PARANTHESIS  ----------------
1165 C
1166  3600 IF(STACK(VALTOP).LT.8)CALL SVALUE
1167
1168       GO TO 40
1169 C
1170 C---------------        ----------------------------
1171  3700 CONTINUE
1172       GO TO 40
1173 C---------------  LOWINDEX  ------------------------
1174 C     NA CZUBKU POWINIEN BYC ELEMENT SPROWADZALNY DO WARTOSCI INTEGER
1175  3800 CALL SINDTYP
1176       GO TO 40
1177 C---------------  LSE  -----------------------------
1178 C     NA CZUBKU POWINNA BYC LEWA STRONA PODSTAWIENIA: UNIWERSALNY,
1179 C     ZMIENNA,ELEM. TABLICY,TABLICA STATYCZNA LUB - DLA INICJALIZACJI-
1180 C     STALA DEFINIOWANA
1181 C
1182  3900 LSTLSE=VALTOP
1183       ELEM=STACK(VALTOP)+1
1184       IF(ELEM.GT.6)GO TO 3980
1185       GO TO(40,3910,3980,40,40,40),ELEM
1186 C.....STALA. LEGALNE TYLKO PODCZAS INICJALIZACJI.
1187  3910 IF(INICJA)GO TO 40
1188 C.....BLAD.
1189  3980 ERROR=420
1190 C     ZASTAP PRZEZ UNIWERSALNY I OBSLUZ OD NOWA
1191       GO TO 9901
1192 C
1193 C---------------  NEW  -----------------------------
1194 C     NA PEWNO BLAD: KLASA /REKORD/ SAMA "ZJADA" NEW
1195 C
1196  4000 ERROR=421
1197       GO TO 9900
1198 C
1199 C---------------  NEWARRAY  ------------------------
1200 C
1201  4100 CALL SNEWARR
1202       GO TO 30
1203 C
1204 C---------------  NOT  -----------------------------
1205 C
1206  4200 CALL SNOT
1207       GO TO 50
1208 C
1209 C---------------  OPERATION  -----------------------
1210 C
1211  4300 CALL SNEXT
1212 C     WB=NUMER OPERACJI
1213       CALL SARITH
1214       GO TO 40
1215 C
1216 C---------------  OPTION  --------------------------
1217 C
1218  4400 CALL SOPTION
1219       GO TO 40
1220 C
1221 C---------------  OR  ------------------------------
1222 C
1223  4500 CALL SBOOLEX(0)
1224       GO TO 40
1225 C
1226 C---------------  OTHERWISE  -------------------------
1227 C
1228  4600 CALL SOTHER
1229       GO TO 40
1230 C
1231 C---------------  PREFBLOCK  -------------------------
1232 C
1233  4700 CALL SNEXT
1234       CALL SPUSH(10)
1235       STACK(VALTOP-1)=0
1236       STACK(VALTOP-7)=0
1237       STACK(VALTOP-4)=IPMEM(WB)
1238       CALL SNEXT
1239       CALL SCALLB
1240       GO TO 50
1241 C---------------  PRIMITIVE TYPE  ------------------
1242 C
1243  4800 CALL SNEXT
1244       CALL SPUSH(7)
1245       STACK(VALTOP-1)=0
1246       STACK(VALTOP-2)=0
1247       STACK(VALTOP-3)=0
1248       STACK(VALTOP-4)=CONSNR(WB)
1249       GO TO 40
1250 C
1251 C---------------  QUA  -----------------------------
1252 C
1253  4900 CALL SVALUE
1254       CALL SNEXT
1255       IF(STACK(VALTOP).EQ.0)GO TO 40
1256       TLDIM=STACK(VALTOP-3)
1257       TLBAS=STACK(VALTOP-4)
1258       IDL=STACK(VALTOP-1)
1259       STACK(VALTOP-4)=MAQUAB(WB)
1260       CALL QUADR3(149,STACK(VALTOP-2),STACK(VALTOP-4))
1261       GO TO 40
1262 C
1263 C---------------  I-O-END  -------------------------
1264 C
1265 C     WYSTAPILY ARGUMENTY ?
1266  5000 IF(FLARGS.LT.2)CALL MERR(444,0)
1267       IF(FILE.NE.0)CALL SPOP
1268       FILE=0
1269       FLARGS=0
1270       FLREADY=.FALSE.
1271       FLMODF=1
1272       GO TO 40
1273 C
1274 C---------------  RELATION  ------------------------
1275 C
1276  5100 CALL SNEXT
1277 C     WB=NUMER RELACJI
1278       CALL SRELAT
1279       GO TO 40
1280 CBC added
1281 C---------------  RESUME  --------------------------
1282 C
1283  5200 call sresum
1284       LSTEMP=TEMPNR
1285       GO TO 30
1286 C
1287 C---------------  RETURN  --------------------------
1288 C
1289  5300 LSTEMP=TEMPNR
1290       CALL SRETURN
1291 cbc   GO TO 40
1292       goto 50
1293 C
1294 C---------------  RIGHT PARENTHESIS  -------------
1295 C
1296  5400 IF(STACK(VLPREV).LT.8)GO TO 1000
1297 C     KONIEC WYWOLANIA
1298       CALL SPARAM
1299       CALL SNEXT
1300       CALL SCALLE
1301       GO TO 50
1302 C
1303 C---------------  START  -------------------------
1304 C
1305  5500 CONTINUE
1306       GO TO 40
1307 C
1308 C---------------  STEP  ---------------------------
1309  5600 CALL SINDTYP
1310       FORSTP=.TRUE.
1311 cdsw&bc
1312 c  check if constant step
1313       if (stack(valtop) .ne. 1) goto 5601
1314 c  yes, error if step < 0
1315       if (stack(valtop-2) .lt. 0) call serror(479)
1316       goto 40
1317
1318  5601 continue
1319 c  not constant
1320 c  generate code to check if step >= 0
1321       call quadr2(240, stack(valtop-2))
1322 c
1323       GO TO 40
1324 C
1325 C---------------  STOP  --------------------------
1326 C
1327  5700 CONTINUE
1328 cbc...
1329       call quadr1(221)
1330 c...bc
1331       GO TO 40
1332 C
1333 C---------------  THIS  --------------------------
1334 C
1335  5800 CALL SNEXT
1336 C     WB=NAZWA PO 'THIS'
1337 C     WEZ Z DISPLAYA ADR.VIRTUALNY,WSTAW NA STOS WARTOSC
1338       CALL SPUSH(2)
1339       STACK(VALTOP-1)=WB
1340       STACK(VALTOP-2)=TSTEMP(4)
1341       STACK(VALTOP-4)=MTHIS(WB)
1342       CALL QUADR3(15,STACK(VALTOP-2),STACK(VALTOP-4))
1343       STACK(VALTOP-3)=0
1344       STACK(VALTOP-5)=0
1345       GO TO 40
1346 C
1347 C---------------  TO  ----------------------------
1348  5900 CALL SFORTO(.TRUE.,FORSTP)
1349       GO TO 40
1350 C
1351 C--------------- WAIT  ---------------------------
1352 C
1353  6000 CONTINUE
1354       GO TO 40
1355 C
1356 C---------------  WRITE  ---------------------------
1357 C6100 CALL SWRITE
1358 cdsw 6100 CALL SWRITE(*30,*40)
1359 C     POWROT DO ETYKIETY 30 LUB 40
1360 cdsw  -----------------------------
1361  6100  call swrite(whdsw)
1362        go to(30,40),whdsw
1363 cdsw  -----------------------------
1364 C
1365 C---------------  WRITELN  -------------------------
1366  6200 CALL SFLADR
1367       FLARGS=2
1368       CALL QUADR2(132,58+FLMODF)
1369       GO TO 40
1370 C
1371 C---------------  BOUNDS  ----------------------------
1372 C
1373  6300 CONTINUE
1374       GO TO 40
1375 C
1376 C---------------  LOWER , UPPER  ----------------------
1377 C
1378 C     CZUBEK STOSU ZAWIERA ADRES TABLICY
1379  6400 CONTINUE
1380  6500 CALL SVALUE
1381 C     WARTOSC TABLICOWA?
1382       ERROR=416
1383       IF(STACK(VALTOP-3).EQ.0)GO TO 9900
1384 C     O.K.
1385       RESULT=TSTEMP(1)
1386       CALL QUADR3(2*WB-95+OPTMEM,RESULT,STACK(VALTOP-2))
1387 C     ZASTAP PRZEZ WARTOSC INTEGER
1388       CALL SRESLT1(NRINT)
1389       GO TO 40
1390 C
1391 C---------------  LOCK , UNLOCK  ---------------------
1392 C
1393  6600 CONTINUE
1394  6700 IDL=WB-33
1395 C     = NUMER PROCEDURY STANDARDOWEJ LOCK,UNLOCK
1396  6710 CALL SVARADR
1397 C     PRZEKAZ ADRES ZMIENNEJ
1398       CALL QUADR4(145,RESULT,IDL,0)
1399 C     WYWOLAJ PROCEDURE
1400       CALL  QUADR2(132,IDL)
1401 C     ZBADAJ TYP : SEMAPHORE ?
1402       IDR=STACK(VALTOP-4)
1403       IF(STACK(VALTOP-3).GT.0.OR.IAND(IPMEM(IDR),15).NE.9)
1404      X     CALL SERROR(418)
1405 C     DLA LOCK,UNLOCK TO JUZ WSZYSTKO
1406       IF(WB.NE.68)GO TO 30
1407 C ... TEST&SET .    ODCZYTAJ WARTOSC
1408       REsULT=TSTEMP(1)
1409       CALL QUADR4(23,RESULT,IDL,1)
1410 C     ZASTAP PRZEZ WARTOSC
1411       CALL SRESLT1(NRBOOL)
1412       GO TO 40
1413 C---------------  TEST&SET  --------------------------
1414  6800 IDL=38
1415       GO TO 6710
1416 C
1417 C---------------  WIND , TERMINATE  ------------------
1418 C
1419 C     NIELEGALNE POZA HANDLEREM
1420  6900 CONTINUE
1421  7000 IF(UNIT.EQ.2)GO TO 7050
1422       CALL MERR(427,0)
1423       GO TO 40
1424 C     O.K.
1425  7050 CALL QUADR1(103+WB)
1426       GO TO 40
1427 C
1428 C---------------  RAISE  -----------------------------
1429 C
1430 C     NA PEWNO BLAD: SYGNAL SAM "ZJADA" RAISE.
1431  7100 CALL SERROR(449)
1432       GO TO 30
1433 C
1434 C---------------  LAST-WILL  -------------------------
1435 C
1436 C     ZAKONCZ INSTRUKCJE MODULU
1437  7200 CALL SFIN
1438       LSTWILL=.TRUE.
1439 C     INNER BEDZIE NIELEGALNY
1440       INNER=4
1441 C     WYPISZ ETYKIETE LAST-WILL
1442       CALL SLWILL
1443       GO TO 40
1444 C
1445 C---------------  READ  ----------------------------
1446 cdsw 7300 CALL SREAD(*30,*40)
1447 cdsw  -------------------------------
1448  7300 call sread(whdsw)
1449       go to(30,40),whdsw
1450 cdsw  --------------------------------
1451 C     POWROT DO ETYKIETY 30 LUB 40
1452 C---------------  READLN  --------------------------
1453  7400 CALL SFLADR
1454       FLARGS=2
1455       CALL QUADR2(132,42-FLMODF)
1456       GO TO 40
1457 C
1458 C---------------  PUT  -----------------------------
1459 C7500 CALL SPUT
1460 cdsw 7500 CALL SPUT(*30,*40)
1461 C     POWROT DO ETYKIETY 30 LUB 40
1462 cdsw  ---------------------------
1463  7500 call sput(whdsw)
1464       go to (30,40),whdsw
1465 cdsw  ---------------------------
1466 C
1467 C---------------  GET  -----------------------------
1468 C7600 CALL SGET
1469 cdsw 7600 CALL SGET(*30,*40)
1470 cdsw  --------------------------
1471  7600  call sget(whdsw)
1472        go to (30,40),whdsw
1473 cdsw  ---------------------------
1474 C     POWROT DO ETYKIETY 30 LUB 40
1475 C
1476 C---------------  OPEN2  ---------------------------
1477  7800 CALL SVALUE
1478       ATS=SVATS(VALTOP)
1479 C     CZUBEK POWINIEN ZAWIERAC NAZWE PLIKU (arrayof char)
1480 cbc   CALL SCHECK(414,NRTEXT)
1481       if (stack(valtop-3) .ne. 1) goto 7801
1482       n = stack(valtop-4)
1483       if (n .ne. nrchr) goto 7801
1484
1485 cfile CALL QUADR4(145,ATS,73,1)
1486 cfile  -------------------------
1487       call quadr4(145,ats,73,2)
1488 cfile  --------------------------
1489       CALL SPOP
1490 C     DALEJ JAK DLA OPEN1
1491 C
1492 C---------------  OPEN1  ---------------------------
1493 cfile 7700 N=STACK(VALTOP)
1494 cfile  -----------  added  ------------------------
1495 c  wspolna obsluga
1496 c  nowa postac OPEN:  OPEN(f,T,nazwa) - proc.stand. 73
1497 c                     OPEN(f,T)       - proc.stand. 72
1498 c T okresla rodzaj operacji. Dozwolone: integer, real ,boolean, char, text
1499 c  zmiana w interpreterze dla procedur standardowych 72 i 73:
1500 c     parametr 0: output, adres nowego obiektu typu file
1501 c     parametr 1: rodzaj operdcji () zalezy do T):
1502 c         1-text, 2-char, 3-int, 4-real, 5-direct
1503 c     parametr 2: nazwa ( tylko dla 73)
1504 c
1505 c  stos zawiera na czubku T, ponizej F
1506 c
1507 7700  continue
1508 c  nazwa typu pierwotnego?
1509       if(stack(valtop).ne.7) go to 7702
1510 c  legalne nazwy typu: text, char ,integer, real
1511       n = stack(valtop-4)
1512 c  n - ident. typu
1513       if(n.eq.nrtext) go to 7701
1514       if(n.eq.nrint) go to 7705
1515       if(n.eq.nrre) go to 7706
1516       if(n.eq.nrchr) go to 7708
1517 cbc
1518       if (n .eq. -17) goto 7709
1519 c  error - nie nazwa typu lub  nielegalny typ
1520 7702  call serror(419)
1521       go to 7715
1522 c  nrtext
1523  7701 n = 1
1524       go to 7710
1525 c  nrint
1526 7705  n = 3
1527       go to 7710
1528 c  nrreal
1529 7706  n = 4
1530       go to 7710
1531 c   nrchr
1532 7708  n = 2
1533       goto 7710
1534 cbc
1535 7709  n = 5
1536 7710  n = sconst(n)
1537       call quadr4(145,n,wb-5,1)
1538 7715  call spop
1539 c
1540       n = stack(valtop)
1541 cfile  -------------------------------------
1542 C     ZMIENNA ?
1543       IF(N.GT.2 .AND. N.LT.6)GO TO 7720
1544       CALL SERROR(420)
1545       GO TO 30
1546 C     TYPU 'FILE'
1547  7720 CALL SFTEST
1548       CALL QUADR2(132,WB-5)
1549       ATS=TSTEMP(4)
1550       CALL QUADR4(23,ATS,WB-5,0)
1551       CALL SSTORE(VALTOP,ATS)
1552       GO TO 30
1553 7801  call serror(416)
1554       goto 30
1555 C
1556 C---------------  EOF0  ----------------------------
1557 C
1558 C     = EOF(INPUT)
1559  7900 CALL SEOF0(39)
1560         GOTO 40
1561 C
1562 C---------------  EOF1  ----------------------------
1563  8000 CALL SEOF(40)
1564       GO TO 40
1565 C     WRACA BEZPOSREDNIO DO ETYKIETY 40
1566 C
1567 C---------------  PAR. INPUT  ----------------------
1568 C UNIMPLEMENTED
1569  8100 CONTINUE
1570 C     PARAMETR INPUT WSTAWKI W ASSEMBLERZE
1571 C8100 CALL SNEXT
1572 C     WB = NUMER REJESTRU.   C.D. DLA IN-OUT
1573 C8150 CALL SVALUE
1574 C     WPISZ NUMER REJESTRU DO SLOWA -1
1575 C     STACK(VALTOP-1)=SREGSTR(WB)
1576 C     ICOUNT=ICOUNT+1
1577 C     GO TO 40
1578 C
1579 C---------------  PAR. OUTPUT  ---------------------
1580 C UNIMPLEMENTED
1581  8200 CONTINUE
1582 C     PARAMETR OUTPUT WSTAWKI W ASSEMBLERZE
1583 C8200 CALL SOUTPAR
1584 C     ZDEJMIJ ZE STOSU
1585 C     GO TO 30
1586 C
1587 C---------------  PAR. INOUT  ----------------------
1588 C UNIMPLEMENTED
1589  8300 CONTINUE
1590 C     PARAMETR IN-OUT WSTAWKI W ASSEMBLERZE
1591 C     NAJPIERW OBSLUZ JAK PAR.OUTPUT, POTEM JAK PAR.INPUT
1592 C8300 CALL SOUTPAR
1593 C     GO TO 8150
1594 C
1595 C---------------  ASSEMBLER  -----------------------
1596 C UNIMPLEMENTED
1597  8400 CONTINUE
1598 C     WSTAWIANY TEKST W ASSEMBLERZE
1599 C8400 CALL SBODY
1600 C     GO TO 40
1601 C
1602 C---------------  EOLN0  ---------------------------
1603 C
1604  8500 CALL SEOF0(74)
1605       GO TO 40
1606 C
1607 C---------------  EOLN1  ---------------------------
1608 C
1609  8600 CALL SEOF(75)
1610       GO TO 40
1611 C
1612 C--------  THIS-COROUTINE  ----------------------------
1613 C
1614  8700 N=NRCOR
1615 C     WLOZ NA STOS 'WARTOSC'
1616  8720 CALL SPUSH(2)
1617       ATS=TSTEMP(4)
1618       STACK(VALTOP-1)=0
1619       STACK(VALTOP-2)=ATS
1620       STACK(VALTOP-3)=0
1621       STACK(VALTOP-4)=N
1622       STACK(VALTOP-5)=0
1623 C     ODCZYTAJ WARTOSC : FUNKCJA STANDARDOWA 76,77
1624       CALL QUADR2(132,WB-11)
1625       CALL QUADR4(23,ATS,WB-11,0)
1626       GO TO 40
1627 C
1628 C---------  THIS-PROCESS  ----------------------------
1629 C
1630  8800 N=NRPROC
1631       GO TO 8720
1632 C
1633 c---------  putrec -----------------------------------
1634 c
1635  8900 call spgrec(83)
1636       goto 30
1637 c
1638 c---------  getrec -----------------------------------
1639  9000 call spgrec(82)
1640       goto 30
1641 c
1642 cbc added concurrent statements
1643 c---------  enable -----------------------------------
1644  9100 call sconc(223)
1645       goto 40
1646 c
1647 c---------  disable ----------------------------------
1648  9200 call sconc(224)
1649       goto 40
1650 c
1651 c---------  accept -----------------------------------
1652  9300 call sconc(225)
1653       goto 40
1654 c---------  procedure list end -----------------------
1655 c error - skip and read next symbol
1656  9400 goto 40
1657 c
1658 C------------------------------------------------------
1659 C
1660 C..........WSPOLNA OBSLUGA BLEDOW. ERROR=NUMER BLEDU.
1661 C     ZASTAPIENIE CZUBKA STOSU PRZEZ UNIWERSALNY Z ZACHOWANIEM NAZWY.
1662 C     WRACA NA POCZATEK PETLI.
1663  9900 CALL SNEXT
1664  9901 CALL SERROR(ERROR)
1665       ELEM=STACK(VALTOP-1)
1666       CALL SPOP
1667       CALL SPUSH(0)
1668       STACK(VALTOP-1)=ELEM
1669       GO TO 50
1670       END
1671       SUBROUTINE SINIT
1672 C------------------------------------------------------
1673 C
1674 C     POMOCNICZA. INICJALIZACJA SLOWNIKA ATRYBUTOW,
1675 C      ZMIENNYCH UNIT,INNER,LSTWILL
1676 C     NIE JEST WOLANA W FAZIE WYLICZANIA STALYCH.
1677 C
1678 C     DLA KLAS WSTAWIA DO SLOWA +1 ZERO.
1679 C     JESLI MODUL MA PREFIKS,WSTAWIA DO SLOWA +1 PREFIKSU 1.
1680 C
1681 C     ##### OUTPUT CODE : 184 .
1682 C
1683 C
1684 #include "stos.h"
1685 #include "blank.h"
1686 C
1687       INTEGER AUX0(8),AUX(7)
1688       EQUIVALENCE (AUX0(2),AUX(1))
1689       DATA AUX0/1,3,5,5,4,4,3,2/
1690 C      = RODZAJ MODULU W ZALEZNOSCI OD POLA "S" ZEROWEGO SLOWA
1691 C
1692 cdsw  DATA STCKAG,STCKA0,STCKAP /0,8,8,8,8,8,10,4,8,8,8,8,8,8,8,8/
1693 cdsw X      ,APETYT /1,2,3,2/
1694 C
1695 C
1696 C.....JAKI TO MODUL ?
1697       LSTWILL=.FALSE.
1698       INNER=1
1699       N=IPMEM(P)
1700 C     SPRAWDZ POLE "S" : BITY 5..7
1701       UNIT=IAND(ISHFT(N,-8),7)
1702       UNIT=AUX(UNIT)
1703 C     MOZE KLASA ? /JESLI POLE "T",BITY 12..15, <> 1 /
1704       IF(IAND(N,15).EQ.1)GO TO 100
1705 C     KLASA
1706       UNIT=6
1707       INNER=0
1708   100 CONTINUE
1709 C.....ZAZNACZ : JESZCZE NIE UZYWANY JAKO PREFIKS
1710       IPMEM(P+1)=0
1711       IF(UNIT.LT.3)GO TO 200
1712 C     JESLI MA PREFIKS - ZAZNACZ DLA PREFIKSU,ZE UZYWANY
1713       IDL=IPMEM(P+21)
1714       IF(IDL.NE.0)IPMEM(IDL+1)=1
1715 C.....WYPISZ : POCZATEK MODULU
1716   200 CALL QUADR2(184,P)
1717       RETURN
1718       END
1719
1720
1721       SUBROUTINE SNEXT
1722 C-----------------------------------------------------------------------------
1723 C
1724 C     DOSTARCZA KOLEJNEGO SYMBOLU KODU POSREDNIEGO WYGENEROWANEGO
1725 C     PRZEZ PARSER. SYMBOL TEN WPISUJE NA WB.
1726 C
1727 C     CZYTA ZE STRUMIENIA "INP" , OPISANEGO W BUFORZE IBUF3 ,DO TABLICY IX .
1728 C
1729 #include "stos.h"
1730 #include "blank.h"
1731 C
1732       COMMON/TEST/TESTC,TESTS,TESTH
1733       LOGICAL TESTC,TESTS,TESTH
1734 C
1735 C
1736       INTEGER CURRENT
1737 C             = INDEKS W BUFORZE IX OSTATNIO WCZYTANEGO SYMBOLU
1738       EQUIVALENCE (IX(257),CURRENT)
1739       INTEGER RECORD
1740 C             = NUMER OSTATNIO WCZYTANEGO REKORDU
1741       EQUIVALENCE (IX(258),RECORD)
1742       COMMON/STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
1743       LOGICAL ERRFLG
1744 C.....OSTATNI W REKORDZIE?
1745       IF(CURRENT.EQ.255)GO TO 200
1746 C     NIE.
1747       CURRENT=CURRENT+1
1748   100 WB=IX(CURRENT)
1749 C
1750 C
1751 C1000 FORMAT(' NEXT, WB =',I6)
1752 C
1753 C
1754       RETURN
1755 C.....OSTATNI. WCZYTAJ KOLEJNY REKORD
1756   200 RECORD=IX(256)
1757 C     SLOWO 256 ZAWIERA NUMER KOLEJNEGO REKORDU
1758       CALL SEEK(IBUF3,RECORD)
1759       CALL GET(IBUF3,IX)
1760       CURRENT=1
1761       GO TO 100
1762       END
1763
1764
1765       SUBROUTINE SATTACH
1766 C------------------------------------------------------
1767 C
1768 C     NA CZUBKU JEST ARGUMENT ATTACH. BADA TYP,GENERUJE KOD,
1769 C     ZDEJMUJE ZE STOSU.
1770 C
1771 C     ##### OUTPUT CODE : 188 .
1772 C
1773 C     ##### DETECTED ERROR(S) : 477
1774 C
1775 #include "stos.h"
1776 #include "option.h"
1777 #include "blank.h"
1778 C
1779 cdsw&ail
1780       common /stacks/ btsins, btstem
1781 C
1782       INTEGER ELEM
1783 C.........
1784       CALL SVALUE
1785       IF(STACK(VALTOP).EQ.0)RETURN
1786       IF(STACK(VALTOP-3).GT.0)GO TO 500
1787       ELEM=STACK(VALTOP-4)
1788       ELEM=IAND(IPMEM(ELEM),15)
1789       IF(ELEM.GT.7 .AND. ELEM.LT.13 .OR. ELEM.EQ.2)GO TO 500
1790       ELEM=STACK(VALTOP-2)
1791 C     ATTACH( NONE ) ?
1792 cdsw&ail      IF(STACK(VALTOP).EQ.1)ELEM=LMEM-3
1793       if (stack(valtop).eq.1) elem = btstem-3
1794 C                           = ATS NONE
1795       CALL QUADR2(188,ELEM)
1796       RETURN
1797 C     NIEPOPRAWNY TYP ARGUMENTU ATTACH
1798   500 CALL SERROR(477)
1799       RETURN
1800       END
1801
1802       SUBROUTINE SCASE
1803 C--------------------------------------------------------------------------
1804 C
1805 C     OBSLUGUJE POCZATEK INSTRUKCJI "CASE".
1806 C     CZUBEK STOSU ZAWIERA WARTOSC WYRAZENIA CASE,NASTEPNY SYMBOL
1807 C       WEJSCIOWY JEST NUMEREM ETYKIETY BAZOWEJ.
1808 C     WKLADA NA STOS W TABLICY LAB OPIS NOWEJ INSTRUKCJI CASE,
1809 C       PRZY CZYM : JESLI ZAGNIEZDZENIE = 4 , WYSYLA OPIS POPRZEDNICH
1810 C        3 CASE-OW NA DYSK JAKO REKORD O NUMERZE IOP(2),USTAWIAJAC OVER=6,
1811 C       JESLI JEDNAK ZAGNIEZDZENIE > 6 , ZWIEKSZA JEDYNIE LICZNIK NADMIAROWYCH
1812 C         ZAGNIEZDZEN.
1813 C
1814 C     OGRANICZENIA : ZAGNIEZDZENIE MUSI BYC < 7 ,
1815 C                    ROZNICA MIEDZY NAJWIEKSZA A NAJMNIEJSZA ETYKIETA < 160 .
1816 C
1817 C     GENERUJE :
1818 C       < CASE , ATS WYRAZENIA , ETYKIETA BAZOWA -1 , OPTCSC+OPTCSF >
1819 C
1820 C
1821 C     ##### OUTPUT CODE : 189 .
1822 C
1823 C     ##### DETECTED ERROR(S) :  402 , 405 .
1824 C
1825 C
1826 #include "stos.h"
1827 #include "option.h"
1828 #include "blank.h"
1829 C
1830       COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
1831       LOGICAL ERRFLG
1832 C     IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
1833 C
1834 C
1835       COMMON/CASE/DEEP,OVER
1836       INTEGER LAB(5000)
1837       EQUIVALENCE(LAB(1),IPMEM(1))
1838 C
1839 cdsw  DATA OVER/0/
1840 #if WSIZE == 4
1841       DATA MAXINTEGER,MININTEGER / x'7FFFFFFF' , x'80000000' /
1842 #else
1843       DATA MAXINTEGER,MININTEGER / x'7fff', -x'7fff' /
1844 #endif
1845 C
1846 C     LAB ZAWIERA OPISY ZAGNIEZDZONYCH INSTRUKCJI CASE.
1847 C       WYKORZYSTYWANYCH JEST 256 SLOW W TABLICY IPMEM :
1848 C       OD LMEM-515 DO LMEM-260 .
1849 C     POSTAC OPISU :
1850 C       SLOWO  0 : TYP WYRAZENIA CASE
1851 C             +1 : NUMER ETYKIETY BAZOWEJ
1852 C             +2 : MINIMALNA WARTOSC ETYKIETY
1853 C             +3 : MAKSYMALNA WARTOSC ETYKIETY
1854 C             +4 : LICZBA ETYKIET
1855 C             +5..+84 : 160 BAJTOW NA WZGLEDNY NUMER ETYKIETY
1856 C     OPIS BIEZACEJ INSTRUKCJI CASE WSKAZANY JEST PRZEZ ZMIENNA DEEP
1857 C       PRZYJMUJACA WARTOSCI : LMEM-600 PRZY BRAKU "CASE",
1858 C                              LMEM-515 PRZY ZAGNIEZDZENIU = 1
1859 C                              LMEM-430 PRZY ZAGNIEZDZENIU = 2
1860 C                              LMEM-345 PRZY ZAGNIEZDZENIU = 3
1861 C                              LMEM-260 PRZY PRZEPELNIENIU
1862 C     PRZY ZAGNIEZDZENIU 4..6 OPIS PIERWSZYCH 3 CASE-OW JEST WYSYLANY
1863 C       NA DYSK JAKO REKORD O NUMERZE IOP(2), OVER PRZYJMUJE WTEDY WARTOSC 6.
1864 C     PRZY  ZAGNIEZDZENIACH > 6 UTRZYMYWANA JEST WARTOSC DEEP=LMEM-260 ,
1865 C      OPISY NOWYCH CASE-OW SA JEDYNIE ZLICZANE NA ZMIENNEJ OVER / 7,8,.../.
1866 C     LAB(LMEM-260) = NRUNIV I JEST WYKORZYSTYWANE DLA UNIKNIECIA SYGNALIZACJI
1867 C      NIEZGODNOSCI TYPOW ETYKIET PRZY ZBYT ZAGNIEZDZONYCH CASE-ACH.
1868 C     DLA ETYKIETY O WARTOSCI N DO BAJTU O NUMERZE /NUMERACJA 0..159/
1869 C     ( N MODE 160 ) WSTAWIANA JEST ROZNICA MIEDZY ODPOWIADAJACYM
1870 C      JEJ NUMEREM ETYKIETY Z PARSERA A ETYKIETA BAZOWA.
1871 C
1872 C
1873 C
1874       CALL SVALUE
1875       CALL SNEXT
1876 C     TERAZ WB = NUMER ETYKIETY BAZOWEJ
1877       IF(STACK(VALTOP).EQ.0)GO TO 150
1878 C ... ZBADAJ TYP
1879       IF(STACK(VALTOP-3).GT.0)GO TO 100
1880       IF(STACK(VALTOP-4).EQ.NRRE)CALL SVINT(VALTOP)
1881       ELEM=STACK(VALTOP-4)
1882 C      = TYP WYRAZENIA CASE /PO EWENT. KONWERSJI REAL->INTEGER /
1883       IF(ELEM.EQ.NRINT .OR. ELEM.EQ.NRCHR)GO TO 200
1884 C     NIELEGALNY TYP WYRAZENIA CASE
1885   100 CALL SERROR(405)
1886   150 ELEM=NRUNIV
1887 C.....DODAJ NOWY OPIS DO STOSU INSTRUKCJI CASE
1888   200 DEEP=DEEP+85
1889       IF(DEEP.LT.LMEM-260)GO TO 500
1890 C     PELNY STOS. BUFOR NA DYSKU JUZ UZYTY ?
1891       IF(OVER.GT.0)GO TO 1000
1892 C     JESZCZE NIE.
1893       OVER=6
1894       DEEP=LMEM-515
1895       CALL SEEK(IBUF3,IOP(2))
1896       CALL PUT(IBUF3,LAB(DEEP))
1897 C
1898 C.....WSTAW OPIS
1899   500 LAB(DEEP)=ELEM
1900       LAB(DEEP+1)=WB
1901       LAB(DEEP+2)=MAXINTEGER
1902       LAB(DEEP+3)=MININTEGER
1903       LAB(DEEP+4)=0
1904 C     JAKO MINIMALNA I MAKSYMALNA ETYKIETA POCZATKOWO NAJWIEKSZA I NAJMNIEJSZA
1905 C       LICZBA ---> POTEM KONIECZNE JEST POROWNANIE KAZDEJ ETYKIETY ZAROWNO
1906 C       Z MINIMALNA JAK I MAKSYMALNA.
1907       DO 600 I=5,84
1908       N=DEEP+I
1909   600 LAB(N)=0
1910 C     BAJT ROWNY ZERO OZNACZA, ZE NIE WYSTAPILA ETYKIETA O WARTOSCI
1911 C       WYZNACZAJACEJ TEN BAJT.
1912 C
1913 C ... JESLI STALA - WSTAW
1914       ELEM=STACK(VALTOP-2)
1915       IF(STACK(VALTOP).EQ.1)ELEM=SCONST(ELEM)
1916 C ... GENERUJ SKOK DO MIEJSCA WYBRANIA WLASCIWEJ INSTRUKCJI
1917       CALL QUADR4(189,ELEM,WB-1,OPTCSC+OPTCSF)
1918       RETURN
1919 C.....PRZEPELNIENIE : ZAGNIEZDZENIE PRZEKRACZA 6 .
1920 C     NIE SYGNALIZUJ BLEDU DLA DALSZYCH ZAGNIEZDZEN
1921  1000 IF(OVER.EQ.6)CALL MERR(402,0)
1922       OVER=OVER+1
1923       DEEP=LMEM-260
1924       LAB(DEEP)=NRUNIV
1925       RETURN
1926       END
1927       SUBROUTINE SCSLAB
1928 C-------------------------------------------------------------------------
1929 C
1930 C     OBSLUGUJE ETYKIETE DLA INSTRUKCJI CASE.
1931 C     CZUBEK STOSU POWINIEN ZAWIERAC WARTOSC ETYKIETY,NASTEPNY SYMBOL
1932 C       TO NUMER ETYKIETY WYGENEROWANEJ PRZEZ PARSER.
1933 C     PROCEDURA SPRAWDZA,CZY CZUBEK STOSU ZAWIERA STALA TYPU ZGODNEGO
1934 C       Z TYPEM WYRAZENIA CASE I CZY WARTOSC TA JUZ NIE WYSTAPILA
1935 C      LUB CZY ROZNICA MIEDZY MAKS. I MIN. ETYKIETA < 160.
1936 C     WYZNACZA NOWA WARTOSC ETYKIETY MAKS. I MIN. ORAZ DO BAJTU
1937 C       WYZNACZONEGO PRZEZ WARTOSC ETYKIETY WSTAWIA ROZNICE MIEDZY
1938 C       NUMEREM ODPOWIADAJACEJ ETYKIETY A ETYKIETA BAZOWA.
1939 C     ZWIEKSZA LICZNIK ETYKIET.
1940 C       W PRZYPADKU, GDY ROZPIETOSC ETYKIET PRZEKRACZA 160,ZMIENIA
1941 C        ETYKIETE BAZOWA NA -1 /DLA UNIKNIECIA DALSZEJ SYGNALIZACJI
1942 C        TEGO BLEDU/.
1943 C
1944 C
1945 C     ##### DETECTED ERROR(S) :  401 , 403 , 404 , 406 .
1946 C
1947 C
1948 #include "stos.h"
1949 #include "blank.h"
1950 C
1951       COMMON/CASE/DEEP,OVER
1952       INTEGER LAB(5000)
1953       EQUIVALENCE(LAB(1),IPMEM(1))
1954 C
1955 C
1956 C     TRICK FOR HAVING 2 RIGHTMOST BYTES ADDRESSABLE
1957 cdsw  INTEGER BYTES
1958 cdsw  BYTE  BYTE(4)
1959 cdsw  EQUIVALENCE ( BYTES , BYTE(1) )
1960 C
1961 C
1962 C
1963       CALL SNEXT
1964 C     WB = NUMER ETYKIETY Z PARSERA. SPRAWDZ, CZY NA STOSIE JEST STALA
1965       N=STACK(VALTOP)
1966       IF(N.EQ.0)RETURN
1967       IF(N.EQ.1)GO TO 100
1968 C ... JAKO ETYKIETA W "CASE"  WYSTAPIL OBIEKT ROZNY OD STALEJ
1969       CALL SERROR(401)
1970       RETURN
1971 C
1972 C.....ZBADAJ ZGODNOSC TYPOW /JESLI NIE BYLO PRZEPELNIENIA/
1973   100 IF(STACK(VALTOP-4).EQ.LAB(DEEP))GO TO 200
1974 C     NIEZGODNOSC TYPOW ETYKIETY I WYRAZENIA "CASE"
1975       IF(LAB(DEEP).NE.NRUNIV)CALL SERROR(406)
1976       RETURN
1977 C
1978 C.....USTAL NOWE WARTOSCI ETYKIET : MINIMALNA I MAKSYMALNA.
1979 C      /UWAGA: ZE WZGLEDU NA INICJALIZACJE KONIECZNE OBA POROWNANIA/
1980   200 N=STACK(VALTOP-2)
1981       IF(N.LT.LAB(DEEP+2))LAB(DEEP+2)=N
1982       IF(N.GT.LAB(DEEP+3))LAB(DEEP+3)=N
1983       IF(LAB(DEEP+3)-LAB(DEEP+2).LT.160)GO TO 300
1984 C     ROZPIETOSC WARTOSCI ETYKIET PRZEKRACZA 160
1985       IF(LAB(DEEP+1).EQ.-1)RETURN
1986       CALL SERROR(403)
1987       LAB(DEEP+1)=-1
1988       RETURN
1989 C.....WYZNACZ NUMER BAJTU
1990   300 N=MOD(N,160)
1991       IF(N.LT.0)N=N+160
1992       L=N/2+DEEP+5
1993 C      = NUMER SLOWA W LAB
1994       m = lab(l)
1995 C      = WARTOSC TEGO SLOWA
1996       WB=WB-LAB(DEEP+1)
1997 C     ZWIEKSZ LICZNIK ETYKIET
1998       LAB(DEEP+4)=LAB(DEEP+4)+1
1999 C     PARZYSTY BAJT ?
2000       IF(IAND(N,1).EQ.0)GO TO 500
2001 C ... NIEPARZYSTY, PRAWY BAJT. ETYKIETA JUZ WYSTAPILA ?
2002       if(iand(m,x'00ff').eq.0) go to 400
2003 C ... POWTORNE WYSTAPIENIE TEJ SAMEJ ETYKIETY
2004   350 CALL SERROR(404)
2005       RETURN
2006 C     WSTAW ROZNICE : NUMER ETYKIETY - ETYKIETA BAZOWA
2007  400  lab(l) = ior(m,wb)
2008       RETURN
2009 C ... PARZYSTY, LEWY BAJT
2010  500  if(iand(ishft(m,-8),x'00ff').ne.0) go to 350
2011       lab(l) = ior(ishft(wb,8),m)
2012       return
2013       END
2014       SUBROUTINE SOTHER
2015 C--------------------------------------------------------------------------
2016 C
2017 C     WOLANA PO WYSTAPIENIU "OTHERWISE" W INSTRUKCJI "CASE" .
2018 C     WYPISUJE ETYKIETY /POPRZEZ SCSOUT/ I ZAZNACZA TO POPRZEZ ZMIANE
2019 C       SLOWA 0 OPISU CASE NA NRUNIV.
2020 C
2021 #include "stos.h"
2022 #include "blank.h"
2023 C
2024       COMMON/CASE/DEEP,OVER
2025       INTEGER LAB(5000)
2026       EQUIVALENCE(LAB(1),IPMEM(1))
2027 C
2028 C
2029       IF(LAB(DEEP).EQ.NRUNIV)RETURN
2030 C     WYPISZ ETYKIETY I ZAZNACZ TO
2031       CALL SCSOUT
2032       LAB(DEEP)=NRUNIV
2033       RETURN
2034       END
2035       SUBROUTINE SCSOUT
2036 C----------------------------------------------------------------------------
2037 C
2038 C
2039 C     WOLANA : PRZED "OTHERWISE" /JESLI WYSTAPILO/ LUB PRZY "ESAC" .
2040 C
2041 C     WYPISUJE ETYKIETY DLA "CASE".
2042 C     POSTAC : "ESAC" / =190 /
2043 C               LICZBA ETYKIET
2044 C               NUMER ETYKIETY BAZOWEJ
2045 C               WARTOSC ETYKIETY MINIMALNEJ
2046 C               DLA KAZDEJ ETYKIETY SLOWO ZAWIERAJACE :
2047 C                LEWY BAJT = ETYKIETA - ET.MINIMALNA
2048 C                PRAWY BAJT = ODLEGLOSC OD ETYKIETY BAZOWEJ
2049 C                - W KOLEJNOSCI OD ETYKIETY MINIMALNEJ DO MAKSYMALNEJ.
2050 C
2051 C     NA KONCU DOPISUJE ETYKIETE DLA "OTHERWISE" /BAZOWA/ ,NIEZALEZNIE
2052 C       OD TEGO,CZY "OTHERWISE" WYSTAPILO.
2053 C
2054 C
2055 C     ##### OUTPUT CODE : 181 , 190 .
2056 C
2057 #include "stos.h"
2058 #include "blank.h"
2059 C
2060       COMMON/STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
2061       LOGICAL ERRFLG
2062 C
2063       COMMON/CASE/DEEP,OVER
2064       INTEGER LAB(5000)
2065       EQUIVALENCE(LAB(1),IPMEM(1))
2066 C
2067 C     TRICK FOR HAVING 2 RIGHTMOST BYTES ADDRESSABLE
2068 cdsw  INTEGER BYTES,OBYTES
2069 cdsw  BYTE  BYTE(4),OBYTE(4)
2070 cdsw  EQUIVALENCE ( BYTES , BYTE(1) ) , ( OBYTES , OBYTE(1) )
2071 C
2072       INTEGER N,NR,DIFF,L,BOUND
2073 C
2074 C
2075       IF(ERRFLG)RETURN
2076       N=LAB(DEEP+2)
2077 C      = ETYKIETA MINIMALNA
2078       NR=LAB(DEEP+4)
2079 C      = LICZBA ETYKIET
2080 C     WYPISZ "ESAC",LICZBA ETYKIET,ETYKIETA BAZOWA I MINIMALNA
2081       CALL QUADR4(190,NR,LAB(DEEP+1),N)
2082 C
2083 C.....WYPISZ DLA KAZDEJ ETYKIETY 2 BAJTY :
2084 C      LEWY = ET. - ET.MIN. , PRAWY = NUMER - ETYKIETA BAZOWA
2085 C
2086 C     DALEJ :
2087 C     DALEJ :
2088 C        DIFF = BIEZACA ETYKIETA - ET.MINIMALNA
2089 C        L = NUMER SLOWA DLA KOLEJNEJ ETYKIETY
2090 C        K = WARTOSC SLOWA
2091 C        NR = LICZBA ETYKIET DO WYPISANIA
2092 C        BOUND = NUMER PIERWSZEGO SLOWA ZA OPISEM "CASE"
2093 C
2094       BOUND=DEEP+85
2095       N=MOD(N,160)
2096       IF(N.LT.0)N=N+160
2097 C     = NUMER BAJTU DLA ETYKIETY MINIMALNEJ , 0..159
2098       DIFF=-1
2099       L=DEEP+5+N/2
2100 C      = NUMER SLOWA
2101 cdsw  OBYTES=0
2102       BYTES=LAB(L)
2103 C     PARZYSTA ?
2104       IF(IAND(N,1).NE.0)GO TO 300
2105 C ... PARZYSTY,LEWY BAJT
2106   200 DIFF=DIFF+1
2107 C     WEZ LEWY BAJT
2108       byte = iand(ishft(bytes,-8),X'00ff')
2109       if(byte.eq.0) go to 300
2110 C     WYPISZ PARE DLA TEJ ETYKIETY
2111       call quadr1(ior(byte,ishft(diff,8)))
2112       NR=NR-1
2113       IF(NR.EQ.0)GO TO 1000
2114 C ... NIEPARZYSTY,PRAWY BAJT
2115   300 DIFF=DIFF+1
2116 C     WEZ PRAWY BAJT
2117       byte = iand(bytes,X'00ff')
2118       if(byte.eq.0) go to 400
2119 C     WYPISZ PARE DLA TEJ ETYKIETY
2120       call quadr1(ior(ishft(diff,8),byte))
2121       NR=NR-1
2122       IF(NR.EQ.0)GO TO 1000
2123 C ... ZWIEKSZ NUMER SLOWA/ ZWAZAJAC NA GRANICE / I WCZYTAJ TO SLOWO
2124   400 L=L+1
2125       IF(L.EQ.BOUND)L=L-80
2126       BYTES=LAB(L)
2127       GO TO 200
2128 C.....WYPISZ ETYKIETE DLA "OTHERWISE"
2129  1000 CALL QUADR2(181,LAB(DEEP+1))
2130       RETURN
2131       END
2132       SUBROUTINE SESAC
2133 C----------------------------------------------------------------------------
2134 C
2135 C     OBSLUGUJE ZAKONCZENIE INSTRUKCJI "CASE".
2136 C     OBNIZA STOS INSTRUKCJI CASE.
2137 C     JESLI NIE WYSTAPILO "OTHERWISE" I NIE BYLO PRZEPELNIENIA
2138 C     WYPISUJE ETYKIETY /PRZEZ SCSOUT/
2139 C
2140 #include "stos.h"
2141 #include "blank.h"
2142 C
2143       COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
2144       LOGICAL ERRFLG
2145 C     IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
2146 C
2147 C
2148       COMMON/CASE/DEEP,OVER
2149       INTEGER LAB(5000)
2150       EQUIVALENCE(LAB(1),IPMEM(1))
2151 C
2152 C
2153 C.....WYPISZ ETYKIETY / O ILE NIE WYSTAPILO "OTHERWISE" LUB PRZEPELNIENIE/
2154       IF(LAB(DEEP).NE.NRUNIV)CALL SCSOUT
2155       IF(OVER.GT.6)GO TO 500
2156       DEEP=DEEP-85
2157       IF(DEEP.GT.LMEM-600)RETURN
2158 C     POBRAC OPIS Z DYSKU ?
2159       IF(OVER.EQ.0)RETURN
2160       CALL SEEK(IBUF3,IOP(2))
2161       CALL GET(IBUF3,LAB(LMEM-515))
2162       OVER=0
2163       DEEP=LMEM-345
2164       RETURN
2165 C.....PRZEPELNIENIE.
2166   500 OVER=OVER-1
2167       RETURN
2168       END
2169       SUBROUTINE SEND
2170 C-------------------------------------------------------------------------
2171 C
2172 C     WOLANA PRZY END MODULU.
2173 C     JESLI TRZEBA, DOPISUJE LAST-WILL.
2174 C     WYPISUJE ZAKONCZENIE LAST-WILL.
2175 C
2176 C     ##### OUTPUT CODE : 175 , 185 , 193 .
2177 C
2178 C
2179 #include "stos.h"
2180 #include "blank.h"
2181 C
2182 C.....BYLO LAST-WILL ?
2183       IF(LSTWILL)GO TO 1000
2184 C     NIE. ZAKONCZ INSTRUKCJE MODULU
2185       CALL SFIN
2186 C              I DOPISZ LAST-WILL
2187       CALL SLWILL
2188 C
2189 C.....WYPISZ ZAKONCZENIE LAST-WILL: SKOK ZA LAST-WILL PREFIKSU
2190 C                                    LUB BACK
2191  1000 IF(UNIT.LE.2)GO TO 2000
2192       IDL=IPMEM(P+21)
2193 C     JESLI NIE MA PREFIKSU - BACK
2194       IF(IDL.EQ.0)GO TO 2000
2195 C     PREFIKSOWANY. CZY W CIAGU PREFIKSOWYM BYLO LAST-WILL ?
2196 C          /TAK, GDY SLOWO +8 PREFIKSU  <> 0  /
2197       IDL=IPMEM(IDL+8)
2198       IF(IDL.EQ.0)GO TO 2000
2199 C     SKOK ZA LAST-WILL W SEKWENCJI PREFIKSOWEJ
2200       CALL QUADR2(175,IDL)
2201       GO TO 3000
2202 C.....BACK
2203 cdsw 2000 CALL QUADR1(193)
2204 cdsw  ---------------------------------------
2205 c   jesli coroutina/process to FIN (194)
2206 2000  n = iand(ipmem(p),15)
2207 c  pole = t
2208       if(n.eq.5.or.n.eq.7) go to 2100
2209       call quadr1(193)
2210       go to 3000
2211 c  coroutina/ process
2212 2100  call quadr1(194)
2213 cdsw  ----------------------------------------
2214 C
2215 C.....WYPISZ ZNACZNIK KONCA MODULU
2216  3000 CALL QUADR1(185)
2217       RETURN
2218       END
2219       SUBROUTINE SFIN
2220 C-------------------------------------------------------------------
2221 C
2222 C     OBSLUGUJE KONIEC INSTRUKCJI MODULU / LAST-WILL LUB END,
2223 C                                JESLI LAST-WILL NIE WYSTAPILO/
2224 C     KOLEJNE DWA SYMBOLE TO : NUMER ETYKIETY, NUMER LINII.
2225 C
2226 C     JESLI TRZEBA,DOPISUJE INNER.
2227 C     DOPISUJE ETYKIETE ORAZ NUMER LINII PRZED END.
2228 C     DLA MODULOW PREFIKSOWANYCH GENERUJE SKOK ZA INNER,DLA POZOSTALYCH
2229 C     END BLOKU /BACKBL/ LUB END PROCEDURY,FUNKCJI /BACKPR/ LUB
2230 C     END KLASY,COROUTINY /FIN/ LUB END HANDLERA /TERMINATE/.
2231 C
2232 C     ##### OUTPUT CODE : 172 , 177 , 178 , 181 , 183 ,
2233 C                            191 , 192 , 194 .
2234 C
2235 #include "stos.h"
2236 #include "option.h"
2237 #include "blank.h"
2238 C
2239       INTEGER AUX(6)
2240       DATA AUX/191,172,194,192,192,194/
2241 C     POWROTY Z MODULU: BACKBL,TERMINATE,FIN,BACKPR,BACKPR,FIN .
2242 C
2243 C.....DOPISAC INNER?
2244       IF(INNER.NE.0)GO TO 10
2245       CALL QUADR2(178,IPMEM(P+23))
2246 C     ZAZNACZ BRAK INSTRUKCJI PO INNER /CHYBA,ZE Z PREFIKSU/
2247       IPMEM(P-7)=0
2248       IDL=IPMEM(P+21)
2249 C     IDL=PREFIKS LUB 0
2250       IF(IDL.NE.0)IPMEM(P-7)=IPMEM(IDL-7)
2251 C.....DOPISZ ETYKIETE O NUMERZE WB
2252    10 CALL SNEXT
2253       CALL QUADR2(181,WB)
2254 C ... DOPISZ NUMER LINII
2255       CALL SNEXT
2256       IF(.NOT.OPTTRC)WB=-WB
2257       CALL QUADR2(177,WB)
2258       IF(UNIT.GT.2)GO TO 200
2259 C ... BLOK LUB HANDLER
2260   100 CALL QUADR1(AUX(UNIT))
2261       RETURN
2262 C ... PREFIKSOWANY ?
2263   200 IDL=IPMEM(P+21)
2264       IF(IDL.EQ.0)GO TO 100
2265 C     TAK. CZY SA INSTRUKCJE PO INNER ?
2266       IDL=IPMEM(IDL-7)
2267       IF(IDL.EQ.0)GO TO 100
2268 C ... SKOK ZA INNER PREFIKSU
2269       CALL QUADR2(183,IDL)
2270       RETURN
2271       END
2272       SUBROUTINE SLWILL
2273 C----------------------------------------------------------------------
2274 C
2275 C     WYPISUJE ETYKKIETE LAST-WILL.
2276 C     DLA KLASY WPISUJE DO SLOWA +8 INFORMACJE O LAST-WILL:
2277 C        NUMER NAJBLIZSZEGO MODULU W CIAGU PREFIKSOWYM /Z BIEZACYM
2278 C         MODULEM WLACZNIE/ MAJACEGO LAST-WILL LUB ZERO,JESLI
2279 C        W CALYM CIAGU PREFIKSOWYM LAST-WILL NIE WYSTAPILO.
2280 C
2281 C     ##### OUTPUT CODE : 174 .
2282 C
2283 #include "stos.h"
2284 #include "blank.h"
2285 C
2286 C.....WYPISZ ETYKIETE LAST-WILL
2287       CALL QUADR1(174)
2288       IF(UNIT.NE.6)RETURN
2289 C ... KLASA
2290       IDR=0
2291 C     JESLI JEST PREFIKS - SKOPIUJ Z PREFIKSU
2292       IDL=IPMEM(P+21)
2293       IF(IDL.NE.0)IDR=IPMEM(IDL+8)
2294 C     JESLI W TYM MODULE WYSTAPILO LAST-WILL, TO WPISZ NUMER BIEZACEGO
2295 C       MODULU
2296       IF(LSTWILL)IDR=P
2297       IPMEM(P+8)=IDR
2298       RETURN
2299       END
2300       SUBROUTINE SRETURN
2301 C-----------------------------------------------------------------
2302 C
2303 C     DLA WYSTAPIENIA "RETURN" GENERUJE :
2304 C             DLA PROCEDUR,FUNKCJI BEZ PREFIKSU BACKPR, DLA PREFIKSOWANYCH
2305 C     LUB KLAS,COROUTIN BACK, DLA BLOKOW BACKBL, DLA HANDLERA BACKHD.
2306 C
2307 C
2308 C     ##### OUTPUT CODE : 180 , 191 , 192 , 193 .
2309 C
2310 #include "stos.h"
2311 #include "blank.h"
2312 C
2313       INTEGER AUX(6)
2314       DATA AUX/191,180,193,192,192,193/
2315 C     POWROTY Z MODULU : BACKBL,BACKHD,BACK,BACKPR,BACKPR,BACK
2316 C
2317 C
2318       IDL=AUX(UNIT)
2319 cbc added concurrent statements
2320       call snext
2321 c check if procedure or function
2322       if (unit .ne. 4 .and. unit .ne. 5) goto 100
2323 c generate BACKRPC
2324       call quadr1(227)
2325 10    op = wb
2326       if (op .ne. 91 .and. op .ne. 92) goto 40
2327 c process next ENABLE/DISABLE list
2328 20    call snext
2329       if (wb .ne. 28) goto 10
2330 c process next identifier
2331       call snext
2332       ind = mident(wb)
2333       elem = swhat(ind)
2334 c check if procedure or function
2335       if (elem .ne. 11 .and. elem .ne. 12) goto 30
2336       if (op .eq. 92) ind = -ind
2337       call quadr1(ind)
2338       goto 20
2339 30    call serror(478)
2340       goto 20
2341 40    call quadr1(0)
2342       call snext
2343       return
2344 c
2345 Cbc   JESLI MODUL PREFIKSOWANY TO BACK
2346 cbc   IF(UNIT.GT.2 .AND. IPMEM(P+21).NE.0)IDL=193
2347 100   CALL QUADR1(IDL)
2348       RETURN
2349       END
2350       SUBROUTINE SFORTO(UP,STEP)
2351 C-----------------------------------------------------------------------------
2352 C
2353 C     OBSLUGUJE POCZATEK PETLI FOR.
2354 C     WOLANA PO WYSTAPIENIU SYMBOLU "TO" LUB "DOWNTO".
2355 C     UP = TRUE ,JESLI BYLO "TO"
2356 C     STEP = TRUE ,JESLI WYSTAPILO "STEP"
2357 C     STOS ZAWIERA: ZMIENNA STERUJACA,WARTOSC POCZATKOWA,KROK/JESLI BYL/,
2358 C     WARTOSC KONCOWA.
2359 C     NASTEPNE 2 SYMBOLE WEJSCIOWE TO NUMERY ETYKIET POCZATKU PETLI I ZA PETLA
2360 C     WCZYTUJE OBA NUMERY,ZASTEPUJE 4 LUB 3 GORNE ELEMENTY STOSU PRZEZ
2361 C     OPIS PETLI FOR.
2362 C       JESLI KROK LUB WARTOSC KONCOWA NIE SA STALE, PRZYDZIELA IM ATRYBUTY
2363 C     ROBOCZE ZYWE PO WYJSCIU Z BLOKU BAZOWEGO ORAZ GENERUJE MOVE&SAFE
2364 C      DLA NICH.
2365 C
2366 C     GENERUJE KOD :
2367 C         WSTAWIENIE WARTOSCI POCZATKOWEJ DO R5 ,
2368 C          ETYKIETA POCZATKU PETLI ,
2369 C           PODSTAWIENIE WARTOSCI Z R5 NA ZMIENNA STERUJACA ,
2370 C            RELACJA I SKOK WARUNKOWY /WYJSCIE Z PETLI/
2371 C
2372 C
2373 C
2374 C     ##### OUTPUT CODE : 13 , 60 , 90 , 92 , 108 , 110 ,
2375 C                            139 , 152 , 181 , 208 .
2376 C
2377 C
2378 #include "stos.h"
2379 #include "blank.h"
2380 cdsw  DATA SFTHEX1,SFTHEX2,SFTHEX3 /Z8000,Z4000,Z2000 /
2381 C
2382       LOGICAL UP,STEP,END1
2383 C       TRUE,JESLI: BYLO "TO", BYLO "STEP" , WARTOSC KONCOWA ROZNA OD STALEJ
2384       INTEGER END2,STEP1,STEP2
2385 C       ATS LUB WARTOSC STALEJ DLA WARTOSCI KONCOWEJ,RODZAJ KROKU
2386 C        /1 JESLI STALY/, ATS LUB WARTOSC KROKU.
2387 C
2388 cdsw  ------------------------------------------------
2389       data sfthx2, sfthx3 / x'4000', x'2000' /
2390       sfthx1 = ishft(1,15)
2391 cdsw  ------------------------------------------------
2392 C
2393 C.....WARTOSC KONCOWA
2394       CALL SINDTYP
2395       END1=STACK(VALTOP).NE.1
2396       END2=STACK(VALTOP-2)
2397       CALL SPOP
2398 C     JESLI TRZEBA - ZABEZPIECZ WARTOSC KONCOWA
2399       IF(.NOT.END1)GO TO 100
2400 C     ZABEZPIECZ
2401       CALL QUADR3(208,TEMPNR+6,END2)
2402       END2=TEMPNR+6
2403 C
2404 C.....BYLO "STEP" ?
2405   100 IF(STEP)GO TO 200
2406 C     NIE.  WSTAW KROK=1
2407       STEP1=1
2408       STEP2=1
2409       GO TO 300
2410 C     TAK.
2411   200 STEP1=STACK(VALTOP)
2412       STEP2=STACK(VALTOP-2)
2413       CALL SPOP
2414 C     STALY KROK? JESLI NIE - ZABEZPIECZ
2415       IF(STEP1.EQ.1)GO TO 300
2416       CALL QUADR3(208,TEMPNR+3,STEP2)
2417       STEP2=TEMPNR+3
2418 C
2419 C.....WARTOSC POCZATKOWA. WPISZ DO "R5"
2420   300 N=SVATS(VALTOP)
2421       K=STACK(VLPREV-2)
2422 C     K = ATS ZMIENNEJ  STERUJACEJ
2423       CALL SPOP
2424 C     ZDEJMIJ TEZ ZMIENNA STERUJACA
2425       CALL SPOP
2426       LSTLSE=0
2427 C     WPISZ WARTOSC POCZATKOWA DO R5 ( REJESTR = 4 )
2428       CALL QUADR3(139,N,4)
2429 C
2430 C
2431 C.....WSTAW OPIS PETLI NA STOS
2432 C
2433 C     POSTAC OPISU : SLOWO -1 = ATS ZMIENNEJ STERUJACEJ
2434 C                    SLOWO -2 = WARTOSC LUB ATS KROKU
2435 C                    SLOWO -3 : BIT 0 = 0 --> "TO",= 1 --> "DOWNTO"
2436 C                               BIT 1 = 0 --> STALY KROK,= 1 --> WYLICZONY
2437 C                               BIT 2 = 0 --> STALA WARTOSC KONCOWA,
2438 C                                                 = 1 --> WYLICZONA
2439 C
2440       CALL SPUSH(6)
2441       LSTFOR=VALTOP
2442       STACK(VALTOP-1)=K
2443       STACK(VALTOP-2)=STEP2
2444       N=0
2445 C      = "TO" , STALY KROK , STALA WARTOSC KONCOWA
2446       IF(.NOT.UP)N=IOR(N,SFTHX1)
2447       IF(STEP1.NE.1)N=IOR(N,SFTHX2)
2448       IF(END1)N=IOR(N,SFTHX3)
2449       STACK(VALTOP-3)=N
2450 C
2451 C
2452 C.....POCZATEK PETLI.
2453       CALL SNEXT
2454 C     WB=NUMER ETYKIETY POCZATKU. GENERUJ ETYKIETE.
2455       CALL QUADR2(181,WB)
2456       CALL SNEXT
2457 C     WB=NUMER ETYKIETY ZA PETLA
2458 C
2459 C ... PODSTAW WARTOSC Z R5 NA ZMIENNA STERUJACA
2460       L=TSTEMP(1)
2461 C     4  -->  R5
2462       CALL QUADR3(13,L,4)
2463       CALL QUADR3(60,K,L)
2464 C
2465 C ... GENERUJ POROWNANIE
2466       STEP1=TSTEMP(1)
2467       N=110
2468 C     ="GT INTEGER"
2469 C     STALA WARTOSC KONCOWA?
2470       IF(END1)GO TO 500
2471 C     TAK
2472       N=92
2473 C     = "GT CONST"
2474 C
2475 C.....POROWNANIE I WYSKOK ZA PETLE
2476   500 IF(.NOT.UP)N=N-2
2477 C     OPKOD "LT" = OPKOD "GT" -2 .
2478       CALL QUADR4(N,STEP1,K,END2)
2479       CALL QUADR3(152,STEP1,WB)
2480       RETURN
2481       END
2482       SUBROUTINE SFOREND
2483 C----------------------------------------------------------------------------
2484 C
2485 C     OBSLUGUJE ZAKONCZENIE PETLI FOR
2486 C     ZWIEKSZA ZMIENNA STERUJACA O KROK /ZMNIEJSZA DLA "DOWNTO"/
2487 C     I WKLADA DO "R5".
2488 C     ZMNIEJSZA LSTFOR,TEMPNR.
2489 C     JESLI KROK LUB WARTOSC KONCOWA NIE BYLY STALE, ZWALNIA
2490 C       ZAJMOWANE PRZEZ NIE ZMIENNE ROBOCZE /GENERUJE "RELEASE"/
2491 C
2492 C     GENERUJE KOD :
2493 C              WSTAWIENIE DO R5 WARTOSCI ZMIENNEJ STERUJACEJ POWIEKSZONEJ
2494 C                 O KROK / POMNIEJSZONEJ DLA DOWNTO / ,
2495 C               SKOK NA POCZATEK PETLI
2496 C
2497 C
2498 C     ##### OUTPUT CODE : 37 , 113 , 114 , 139 , 141 .
2499 C
2500 C
2501 #include "stos.h"
2502 #include "blank.h"
2503 C
2504 C
2505       INTEGER N,STEP,ATS,OPKOD,K
2506 C
2507 cdsw  DATA SFEHEX1,SFEHEX2,SFEHEX3 /Z8000,Z4000, Z2000 /
2508 C
2509 cdsw  ---------------------------------------------------
2510       data sfehx2, sfehx3 /x'4000', x'2000'/
2511       sfehx1 = ishft(1,15)
2512 cdsw  -----------------------------------------------
2513 C..............
2514       N=STACK(VALTOP-3)
2515       STEP=STACK(VALTOP-2)
2516       ATS=STACK(VALTOP-1)
2517       K=TSTEMP(1)
2518 C     "DOWNTO" ?
2519       IF(IAND(N,SFEHX1).NE.0)GO TO 600
2520 C....."TO"
2521       OPKOD=113
2522 C     =" + INTEGER"
2523 C     STALY KROK?  TAK,JESLI BIT 1 = 0
2524       IF(IAND(N,SFEHX2).NE.0)GO TO 400
2525 C     TAK.
2526   200 OPKOD=37
2527 C     =" + CONST"
2528 C
2529   400 CALL QUADR4(OPKOD,K,ATS,STEP)
2530 C     WSTAW DO "R5" ( REJESTR = 4 )
2531       CALL QUADR3(139,K,4)
2532       LSTFOR=VLPREV
2533 C.....ZWOLNIJ ZMIENNE ROBOCZE,JESLI:
2534 C     WARTOSC KONCOWA ROZNA OD STALEJ /BIT 2 = 1/
2535       IF(IAND(N,SFEHX3).NE.0)CALL QUADR2(141,TEMPNR+6)
2536 C     KROK ROZNY OD STALEJ /BIT 1 = 1/
2537       IF(IAND(N,SFEHX2).NE.0)CALL QUADR2(141,TEMPNR+3)
2538 C
2539 C     ZWOLNIJ NUMERY ATRYBUTOW ROBOCZYCH REZERWOWANE DLA PETLI FOR
2540       TEMPNR=TEMPNR+6
2541       RETURN
2542 C
2543 C....."DOWNTO".   STALY KROK?
2544   600 OPKOD=114
2545 C     =" - INTEGER"
2546       IF(IAND(N,SFEHX2).NE.0)GO TO 400
2547 C     TAK
2548       STEP=-STEP
2549       GO TO 200
2550       END
2551       SUBROUTINE SKILL
2552 C---------------------------------------------------------------
2553 C
2554 C     NA CZUBKU JEST ARGUMENT KILL. BADA TYP,GENERUJE KOD.
2555 C
2556 C
2557 C     ##### OUTPUT CODE  : 143 , 146 .
2558 C
2559 C     ##### DETECTED ERROR(S) : 415 .
2560 C
2561 #include "stos.h"
2562 #include "blank.h"
2563 C
2564       CALL SVALUE
2565 C     JESLI UNIWERSALNY-POMIN
2566       IF(STACK(VALTOP).EQ.0)RETURN
2567 C     POMIN TAKZE NONE LUB TYP UNIWERSALNY
2568       IDL=STACK(VALTOP-4)
2569       IF(IDL.EQ.NRNONE .OR. IDL.EQ.NRUNIV)RETURN
2570       IDR=143
2571 C     OPKOD KILL DLA TABLICY,REKORDU
2572 C     TABLICA?
2573       IF(STACK(VALTOP-3).GT.0)GO TO 50
2574 C     NIE. CZY TYP PIERWOTNY?
2575       DO 20 I=1,6
2576       IF(IDL.EQ.CONSNR(I))GO TO 90
2577    20 CONTINUE
2578 C..... O.K.     REKORD? /POLE T=2/
2579       IF(IAND(IPMEM(IDL),15) .NE.2)IDR=146
2580 C     OPKOD UNIWERSALNEGO KILL
2581    50 CALL QUADR2(IDR,STACK(VALTOP-2))
2582       RETURN
2583    90 CALL SERROR(415)
2584       END
2585       SUBROUTINE SOPTION
2586 C------------------------------------------------------
2587 C
2588 C     OBSLUGUJE ZMIANE OPCJI
2589 C
2590 C     NASTEPNY SYMBOL TO + , - NUMER OPCJI.
2591 C
2592 C     NUMER I NAZWA OPCJI * ZMIENNA * WARTOSC DLA + * DLA - * ZNACZENIE DLA +
2593 C
2594 C     M 2 MEMBER CONTROL  * OPTMEM  *     0    *    1   * WYMAGANA KONTROLA
2595 C     O 3 OPTIMIZATION    * OPTOPT  *  TRUE    *  FALSE * WOLNO OPTYMALIZOWAC
2596 C     I 4 INDEX CONTROL   * OPTIND  *     0    *    2   * WYMAGANA KONTROLA
2597 C     T 5 TYPE CONTROL    * OPTTYP  *  FALSE   *  TRUE  * WYMAGANA KONTROLA
2598 C     D 6 TRACE           * OPTTRC  *  TRUE    *  FALSE * WYMAGANY SLAD
2599 C     C 7 CASE CONTROL    * OPTCSC  *     0    *    1   * WYMAGANA KONTROLA
2600 C     F 8 FAST CASE       * OPTCSF  *     0    *    2   * SZYBKI CASE
2601 C
2602 C
2603 C     OPCJA 1 - LISTING - JEST UZYWANA TYLKO PRZEZ PARSER
2604 C
2605 C
2606 C
2607 #include "stos.h"
2608 #include "option.h"
2609 #include "blank.h"
2610 C
2611       INTEGER OPTION(7),PLUS(7),MINUS(7)
2612       LOGICAL LPLUS(7),LMINUS(7)
2613       EQUIVALENCE (OPTION(1),OPTMEM)
2614       EQUIVALENCE (PLUS,LPLUS)
2615       EQUIVALENCE (MINUS,LMINUS)
2616 C     PLUS,LPLUS - WARTOSCI ODPOWIEDNICH ZMIENNYCH DLA ZAPALONEJ OPCJI
2617 C     MINUS,LMINUS -   "        "           "       "  ZGASZONEJ OPCJI
2618 C
2619       DATA PLUS(1),PLUS(3),PLUS(6),PLUS(7)/4*0/
2620       DATA LPLUS(2),LPLUS(4),LPLUS(5)/.TRUE.,.FALSE.,.TRUE./
2621       DATA MINUS(1),MINUS(3),MINUS(6),MINUS(7)/1,2,1,2/
2622       DATA LMINUS(2),LMINUS(4),LMINUS(5)/.FALSE.,.TRUE.,.FALSE./
2623 C
2624 C
2625 C.....WCZYTAJ NUMER OPCJI
2626       CALL SNEXT
2627 C     ZGASZONA ?
2628       IF(WB.GT.0)GO TO 100
2629 C ... TAK
2630       WB=-WB-1
2631       N=MINUS(WB)
2632       GO TO 200
2633 C ... ZAPALONA
2634   100 WB=WB-1
2635       N=PLUS(WB)
2636   200 OPTION(WB)=N
2637       RETURN
2638       END
2639 cdsw  subroutine sread(*,*)
2640       SUBROUTINE SREAD(where)
2641 C-----------------------------------------------------------------------
2642 cdsw   where=1 - return1, where=2 - return2
2643 C
2644 C     OBSLUGUJE OPERACJE CZYTANIA.
2645 C     NA CZUBKU STOSU ZNAJDUJE SIE ARGUMENT LUB ADRES PLIKU
2646 C
2647 C     WRACA DO ETYKIETY 30 LUB 40 W SDPDA
2648 C
2649 C     KORZYSTA Z /BEZPARAMETROWYCH/ STANDARDOWYCH FUNKCJI
2650 C     O NUMERACH :
2651 C                  43,44 - READCHAR
2652 C                  45,46 - READINT
2653 C                  47,48 - READREAL
2654 C
2655 C
2656 C     ##### OUTPUT CODE  : 23 , 132 .
2657 C
2658 C     ##### DETECTED ERROR(S) : 420 , 443 .
2659 C
2660 C
2661 #include "stos.h"
2662 #include "blank.h"
2663 C
2664 C
2665 C
2666       ELEM=STACK(VALTOP)
2667       IF(ELEM.EQ.0)GO TO 500
2668       K=STACK(VALTOP-4)
2669 C     PIERWSZY ARGUMENT ?
2670       IF(FLARGS.GT.0)GO TO 100
2671 C     TAK. FUNKCJA ?
2672       IF(ELEM.EQ.12)GO TO 50
2673 C     NIE. ADRES PLIKU ?
2674       IF(STACK(VALTOP-3).GT.0)GO TO 200
2675       IF(IAND(IPMEM(K),15).NE.11)GO TO 100
2676 C     TAK. PRZEKAZ ADRES PLIKU
2677    50 CALL SVALUE
2678       K=STACK(VALTOP-4)
2679       IF(STACK(VALTOP-3).GT.0)GO TO 200
2680       IF(IAND(IPMEM(K),15).NE.11)GO TO 100
2681       FLMODF=0
2682       FILE=VALTOP
2683       CALL SFLADR
2684       FLARGS=1
2685 C     GO TO 40
2686 cdsw  RETURN2
2687 cdsw  ------------------
2688       where=2
2689       return
2690 cdsw  ------------------
2691 C     POWROT DO PETLI W SDPDA
2692 C
2693 C
2694 C.....ARGUMENT. ZMIENNA ?
2695   100 IF(ELEM.LT.3 .OR. ELEM.GT.5)CALL SERROR(420)
2696 C     WPISZ ADRES PLIKU
2697       CALL SFLADR
2698 C     ZBADAJ TYP, TABLICOWY ?
2699       IF(STACK(VALTOP-3).GT.0)GO TO 200
2700 C     N=NUMER FUNKCJI STANDARDOWEJ ,L=APETYT, K=TYP
2701       N=46
2702       L=1
2703 C     INTEGER?
2704       IF(K.EQ.NRINT)GO TO 300
2705 C     CHAR?
2706       N=44
2707       IF(K.EQ.NRCHR)GO TO 300
2708 C     REAL?
2709       N=48
2710 #if WSIZE == 4
2711       L = 1
2712 #else
2713       L = 2
2714 #endif
2715       IF(K.EQ.NRRE)GO TO 300
2716 C.....ZATEM NIEPOPRAWNY TYP ZMIENNEJ W INSTRUKCJI READ
2717   200 CALL SERROR(443)
2718       GO TO 500
2719 C
2720 C.....OK   PRZEKAZ STEROWANIE DO FUNKCJI STANDARDOWEJ
2721   300 N=N-FLMODF
2722       CALL QUADR2(132,N)
2723 C     ODCZYTAJ WARTOSC
2724       K=TSTEMP(L)
2725       CALL QUADR4(23,K,N,0)
2726 C     WPISZ WARTOSC
2727       CALL SSTORE(VALTOP,K)
2728   500 FLARGS=2
2729 C     POWROT DO ETYKIETY 30 W SDPDA
2730 C     GO TO 30
2731 cdsw  RETURN1
2732 cdsw  ----------------
2733       where=1
2734       return
2735 cdsw  -----------------
2736       END
2737 cdsw  SUBROUTINE SWRITE(*,*)
2738       subroutine swrite(where)
2739 C------------------------------------------------------------------------
2740 cdsw  where = 1 - return1, where = 2 - return2
2741 C
2742 C     OBSLUGUJE OPERACJE PISANIA.
2743 C     NA STOSIE JEST ADRES PLIKU LUB WARTOSC DO WYPISANIA, A NAD NIA 0,1 LUB 2
2744 C     WARTOSCI OKRESLAJACE FORMAT.
2745 C     NASTEPNY SYMBOL = LICZBA WARTOSCI OKRESLAJACYCH FORMAT /0..2/
2746 C     ZDEJMUJE TE WARTOSCI ZE STOSU.
2747 C
2748 C     WRACA DO ETYKIETY 30 LUB 40 W SDPDA
2749 C
2750 C     UZYWA PROCEDUR STANDARDOWYCH :
2751 C        60,61 - WRITECHAR ( ZNAK )
2752 C        62,63 - WRITEINT ( LICZBA , SZEROKOSC POLA )
2753 C        64,65 - WRITEREAL ( LICZBA , LICZBA ZNAKOW PRZED KROPKA , PO KROPCE )
2754 C                            = WRFLT. =
2755 C        66,67 - WRITEREAL   = WRFLE. =
2756 C        68,69 - WRITEREAL   = WRFLF. =
2757 C        70,71 - WRITESTRING ( ADRES TEKSTU , SZEROKOSC POLA LUB -1 )
2758 C
2759 C     DOZWOLONE FORMATY :
2760 C        INTEGER - 0 LUB 1  , DEFAULT = 6
2761 C        CHAR - 0
2762 C        TEXT - 0 LUB 1  , DEFAULT = -1  /=CALY TEKST/
2763 C        REAL - 0 , 1 LUB 2  , DEFAULT = 12 . 4 /=17/
2764 C
2765 C      UWAGA : PARAMETRY / W TYM WARTOSC FUNKCJI / SA NUMEROWANE OD ZERA .
2766 C
2767 C     ##### OUTPUT CODE : 132 , 145 .
2768 C
2769 C     ##### DETECTED ERROR(S) :  441 , 442 .
2770 C
2771 #include "stos.h"
2772 #include "blank.h"
2773 C
2774 C
2775       INTEGER FORMAT(2),I,K,N
2776 C
2777 C
2778       CALL SNEXT
2779 C     WB=LICZBA WYRAZEN OKRESLAJACYCH FORMAT
2780 C.....WSTAW DO TABLICY FORMAT ATS-Y FORMATOW
2781 C
2782       I=WB
2783   100 IF(I.EQ.0)GO TO 200
2784       CALL SINDTYP
2785       FORMAT(I)=SVATS(VALTOP)
2786       CALL SPOP
2787       I=I-1
2788       GO TO 100
2789 C
2790 C.....TERAZ CZUBEK ZAWIERA WARTOSC DO WYPISANIA LUB ADRES PLIKU
2791   200 CALL SVALUE
2792       IF(STACK(VALTOP).EQ.0)GO TO 1000
2793       K=SVATS(VALTOP)
2794 C     ZBADAJ TYP
2795       IF(STACK(VALTOP-3).NE.0)GO TO 400
2796       I=STACK(VALTOP-4)
2797 C     PIERWSZY ARGUMENT ?
2798       IF(FLARGS.GT.0)GO TO 300
2799 C     TAK. ADRES PLIKU ?
2800       IF(IAND(IPMEM(I),15).NE.11)GO TO 300
2801 C     TAK. WYSTAPIL FORMAT ?
2802       IF(WB.NE.0)CALL SERROR(441)
2803       FLMODF=0
2804       FILE=VALTOP
2805       FLARGS=1
2806       CALL SFLADR
2807 C     GO TO 40
2808 cdsw  RETURN2
2809 cdsw  -------------------
2810       where = 2
2811       return
2812 cdsw  --------------------
2813 C     POWROT DO PETLI W SDPDA
2814 C
2815 C.....ARGUMENT
2816   300 CALL SFLADR
2817       IF(I.EQ.NRRE)GO TO 800
2818 C     ZATEM CHAR,INTEGER,TEXT
2819       IF(I.EQ.NRINT)GO TO 500
2820       IF(I.EQ.NRTEXT)GO TO 600
2821       IF(I.EQ.NRCHR)GO TO 700
2822 C
2823 C.....ZATEM NIELEGALNY TYP ARGUMENTU INSTRUKCJI WRITE
2824   400 I=442
2825   410 CALL SERROR(I)
2826       GO TO 1000
2827 C
2828 C....NIELEGALNY FORMAT
2829   420 I=441
2830       GO TO 410
2831 C
2832 C
2833 C.....INTEGER.   DEFAULT : 6 ZNAKOW
2834   500 IF(WB.EQ.2)GO TO 420
2835       IF(WB.EQ.0)FORMAT(1)=SCONST(6)
2836       N=62+FLMODF
2837       GO TO 920
2838 C
2839 C....TEXT.  -1 JESLI BRAK FORMATU
2840   600 IF(WB.EQ.2)GO TO 420
2841       IF(WB.EQ.0)FORMAT(1)=SCONST(-1)
2842       N=70+FLMODF
2843       GO TO 920
2844 C
2845 C.....CHAR
2846   700 IF(WB.NE.0)GO TO 420
2847       N=60+FLMODF
2848       GO TO 930
2849 C
2850 C.....REAL.   DEFAULT : 12 ZNAKOW PRZED KROPKA , 4 PO KROPCE.
2851   800 N=64+2*WB+FLMODF
2852       WB=WB+1
2853       GO TO (810,820,830),WB
2854 C ... BEZ FORMATU , DEFAULT 12.4   , "WRFLT." = 8
2855   810 FORMAT(1)=SCONST(12)
2856       FORMAT(2)=SCONST(4)
2857       GO TO 900
2858 C ... FORMAT = SZEROKOSC POLA , 5 ZNAKOW PO KROPCE, "WRFLE." = 10
2859   820 FORMAT(2)=SCONST(5)
2860 C
2861 C ... FORMAT = SZEROKOSC POLA,LICZBA ZNAKOW PO KROPCE, "WRFLF." = 11
2862   830 CONTINUE
2863 C.....WSTAWIANIE PARAMETROW : N = NUMER PROCEDURY STANDARDOWEJ
2864 C                             K = ATS WARTOSCI
2865 C     WSTAW PRAWY FORMAT DLA REAL
2866   900 CALL QUADR4(145,FORMAT(2),N,2)
2867 C     WSTAW /LEWY/ FORMAT
2868   920 CALL QUADR4(145,FORMAT(1),N,1)
2869 C     WSTAW WARTOSC
2870   930 CALL QUADR4(145,K,N,0)
2871 C     PRZEKAZ STEROWANIE
2872       CALL QUADR2(132,N)
2873  1000 FLARGS=2
2874 C     POWROT DO ETYKIETY 30 W SDPDA
2875 cdsw  RETURN1
2876 cdsw  -----------------
2877       where=1
2878       return
2879 cdsw  -----------------
2880       END
2881       SUBROUTINE SFTEST
2882 C---------------------------------------------------------
2883 C
2884 C     SPRAWDZA, CZY ELEMENT Z CZUBKA STOSU (UNIW.,STALA,
2885 C       WARTOSC,ZMIENNA,TABL.STAT.,ELEM.TABL.) JEST TYPU FILE .
2886 C     'NONE' NIE JEST AKCEPTOWANE
2887 C
2888 C     ##### DETECTED ERROR(S) : 413 .
2889 C
2890 #include "stos.h"
2891 #include "blank.h"
2892 C
2893       N=STACK(VALTOP-4)
2894       IF(STACK(VALTOP-3).GT.0 .OR. (N.NE.NRUNIV.AND.
2895      X  IAND(IPMEM(N),15).NE.11))CALL SERROR(413)
2896       RETURN
2897       END
2898       SUBROUTINE SFLADR
2899 C---------------------------------------------------------
2900 C
2901 C     ZAPEWNIA, ZE (R6-12) ZAWIERA ADRES PLIKU
2902 C        - DLA OPERACJI NA PLIKU WSKAZYWANYM
2903 C
2904 C     ##### OUTPUT CODE : 139 .
2905 C
2906 #include "stos.h"
2907 #include "blank.h"
2908 C
2909       IF(FILE.EQ.0 .OR. FLREADY)RETURN
2910       CALL QUADR3(139,STACK(FILE-2),-45)
2911 C               -45 --> (R6-12)
2912       FLREADY=.TRUE.
2913       RETURN
2914       END
2915 cdsw  SUBROUTINE SPUT(*,*)
2916       subroutine sput(where)
2917 C---------------------------------------------------------
2918 cdsw   where = 1 - return1, where = 2 - return2
2919 C
2920 C     OBSLUGUJE 'PUT' .
2921 C     CZUBEK STOSU ZAWIERA ADRES PLIKU LUB ARGUMENT.
2922 C
2923 C     WRACA BEZPOSREDNIO DO ETYKIETY 30 LUB 40 W SDPDA.
2924 C
2925 C     ##### OUTPUT CODE : 132 , 145 .
2926 C
2927 C     ##### DETECTED ERROR(S) : 445 .
2928 C
2929 #include "stos.h"
2930 #include "blank.h"
2931 C
2932       CALL SVALUE
2933 C     ADRES PLIKU JUZ WYSTAPIL ?
2934       IF(FLARGS.GT.0)GO TO 100
2935 C     JESZCZE NIE
2936       CALL SFTEST
2937       FILE=VALTOP
2938       FLARGS=1
2939       FLMODF=0
2940       CALL SFLADR
2941 C     GO TO 40
2942 cdsw  RETURN2
2943 cdsw  ------------------
2944       where = 2
2945       return
2946 cdsw  ------------------
2947 C     POWROT DO SDPDA
2948 C
2949 C.....ARGUMENT
2950   100 FLARGS=2
2951       CALL SFLADR
2952       N=STACK(VALTOP-4)
2953 C     SEMAPHORE ?
2954       if(iand(ipmem(n),15).eq.9) go to 799
2955       if(stack(valtop-3).gt.0) go to 799
2956       IF(N.EQ.NRINT)GO TO 400
2957       IF(N.EQ.NRCHR)GO TO 300
2958       IF(N.EQ.NRRE )GO TO 500
2959       if(n.eq.nrtext) go to 799
2960 C     ZATEM REFERENCJA lub nielegealny typ
2961       go to 799
2962 CPS  600 N=56        dziwne, ta etykieta nie jest uzywana !
2963 CPS      GO TO 1000
2964   300 N=53
2965       GO TO 1000
2966   400 N=54
2967       GO TO 1000
2968   500 N=55
2969       GO TO 1000
2970 C
2971  1000 CALL QUADR4(145,SVATS(VALTOP),N,0)
2972       CALL QUADR2(132,N)
2973 C     GO TO 30
2974 cdsw  RETURN1
2975 cdsw  ------------------
2976        where = 1
2977        return
2978 cdsw  ------------------
2979 C     POWROT DO SDPDA
2980  799  call serror(445)
2981       where = 1
2982       return
2983       END
2984 cdsw  SUBROUTINE SGET(*,*)
2985       subroutine sget(where)
2986 C---------------------------------------------------------
2987 cdsw  where = 1 - return1 , where = 2 - return2
2988 C
2989 C     OBSLUGUJE 'GET'
2990 C     CZUBEK STOSU ZAWIERA ARGUMENT LUB ADRES PLIKU.
2991 C
2992 C     WRACA DO ETYKIETY 30 LUB 40 W SDPDA.
2993 C
2994 C     ##### OUTPUT CODE : 23 , 132 , 145 .
2995 C
2996 C     #####  DETECTED ERROR(S) : 420 , 446 .
2997 C
2998 #include "stos.h"
2999 #include "blank.h"
3000 C
3001       INTEGER ELEM,N,ATS
3002 C
3003 C     ADRES PLIKU JUZ WYSTAPIL ?
3004       IF(FLARGS.GT.0)GO TO 100
3005 C     JESZCZE NIE
3006       CALL SVALUE
3007       CALL SFTEST
3008       FILE=VALTOP
3009       FLARGS=1
3010       FLMODF=0
3011       CALL SFLADR
3012 C     GO TO 40
3013 cdsw  RETURN2
3014 cdsw  ------------------------
3015       where = 2
3016       return
3017 cdsw  ------------------------
3018 C     POWROT DO SDPDA
3019 C
3020 C.....ARGUMENT. ZMIENNA ?
3021   100 FLARGS=2
3022       CALL SFLADR
3023       ELEM=STACK(VALTOP)
3024       N=STACK(VALTOP-4)
3025 C     SEMAPHORE ?
3026       IF(IAND(IPMEM(N),15).EQ.9)GO TO 9000
3027       if(stack(valtop-3).gt.0) go to 9000
3028       IF(N.EQ.NRINT)GO TO 1000
3029       IF(N.EQ.NRCHR)GO TO 1200
3030       IF(N.EQ.NRRE )GO TO 1100
3031       IF(N.EQ.NRTEXT)GO TO 9000
3032 C     ZATEM REFERENCJA.lub nielegalny typ
3033       go to 9000
3034 C     POWROT DO PETLI W SDPDA
3035 C
3036 C ... INTEGER
3037  1000 N=50
3038       GO TO 1500
3039 C ... REAL
3040  1100 N=51
3041 #if WSIZE == 4
3042       ats = tstemp(1)
3043 #else
3044       ats = tstemp(2)
3045 #endif
3046       GO TO 2000
3047 C ... CHAR
3048  1200 N=49
3049 C
3050 C
3051  1500 ATS=TSTEMP(1)
3052 C     ZMIENNA ?
3053  2000 IF(ELEM.LT.3 .OR. ELEM.GT.5)CALL SERROR(420)
3054       CALL QUADR2(132,N)
3055       CALL QUADR4(23,ATS,N,0)
3056       CALL SSTORE(VALTOP,ATS)
3057 C     GO TO 30
3058 cdsw  RETURN1
3059 cdsw  ----------------
3060       where = 1
3061       return
3062 cdsw  ----------------
3063 C     POWROT DO SDPDA
3064 C.....NIELEGALNY TYP ARGUMENTU
3065  9000 CALL SERROR(446)
3066 C     GO TO 30
3067 cdsw  RETURN1
3068 cdsw  ----------------
3069       where = 1
3070       return
3071 cdsw  -----------------
3072       end
3073       SUBROUTINE SEOF(N)
3074 C--------------------------------------------------------------
3075 cdsw   procedura zostala podzielona na dwie - seof i seof0
3076 C
3077 C     OBSLUGUJE OPERATORY 'EOF' I 'EOLN'.
3078 C     WSTAWIA NA STOS ODCZYTANA WARTOSC FUNKCJI.
3079 C
3080 C     WEJSCIE SEOF0 ODPOWIADA BEZPARAMETROWYM EOF, EOLN.
3081 C     WEJSCIE SEOF ODPOWIADA EOF, EOLN Z PODANYM (NA CZUBKU STOSU)
3082 C       ADRESEM PLIKU (JEST USUWANY).
3083 C     N = NUMER ODPOWIEDNIEJ FUNKCJI STANDARDOWEJ
3084 C            (39, 40 DLA EOF, 74, 75 DLA EOLN)
3085 C
3086 C
3087 C     ###### GENEROWANY KOD : 23 , 132 , 139 .
3088 C
3089 C
3090 #include "stos.h"
3091 #include "blank.h"
3092 C
3093 C
3094 C......CZUBEK STOSU ZAWIERA ADRES PLIKU
3095       CALL SVALUE
3096       CALL SFTEST
3097 C     PRZEKAZ ADRES PLIKU DO (R6-12)
3098       CALL QUADR3(139,STACK(VALTOP-2),-45)
3099       CALL SPOP
3100 C     DALEJ JAK DLA BEZPARAMETROWYCH EOF, EOLN
3101 C
3102       call seof0(n)
3103       return
3104       end
3105       SUBROUTINE SEOF0(N)
3106 C--------------------------------------------------------------
3107 cdsw   procedura zostala podzielona na dwie - seof i seof0
3108 C
3109 C     OBSLUGUJE OPERATORY 'EOF' I 'EOLN'.
3110 C     WSTAWIA NA STOS ODCZYTANA WARTOSC FUNKCJI.
3111 C
3112 C     WEJSCIE SEOF0 ODPOWIADA BEZPARAMETROWYM EOF, EOLN.
3113 C     WEJSCIE SEOF ODPOWIADA EOF, EOLN Z PODANYM (NA CZUBKU STOSU)
3114 C       ADRESEM PLIKU (JEST USUWANY).
3115 C     N = NUMER ODPOWIEDNIEJ FUNKCJI STANDARDOWEJ
3116 C            (39, 40 DLA EOF, 74, 75 DLA EOLN)
3117 C
3118 C
3119 C     ###### GENEROWANY KOD : 23 , 132 , 139 .
3120 C
3121 C
3122 #include "stos.h"
3123 #include "blank.h"
3124 C
3125 C
3126       INTEGER ATS
3127 C...................BEZPARAMETROWE EOF , EOLN
3128 C
3129 C     WYWOLAJ FUNKCJE
3130       CALL QUADR2(132,N)
3131       ATS=TSTEMP(1)
3132 C     PODCZYTAJ WARTOSC ( PARAMETR 0 )
3133       CALL QUADR4(23,ATS,N,0)
3134 C     WSTAW NA STOS ODCZYTANA WARTOSC
3135       CALL SPUSH(2)
3136       STACK(VALTOP-1)=0
3137       STACK(VALTOP-2)=ATS
3138       STACK(VALTOP-3)=0
3139       STACK(VALTOP-4)=NRBOOL
3140       STACK(VALTOP-5)=0
3141       RETURN
3142       END
3143       INTEGER FUNCTION SVATS(ELEM)
3144 C--------------------------------------------------------------
3145 C
3146 C     ZWRACA ATS WARTOSCI Z MIEJSCA ELEM STOSU .
3147 C         (UNIWERSALNY,STALA,WARTOSC)
3148 C       DLA STALEJ GENERUJE NOWY ATS.
3149 C
3150 #include "stos.h"
3151 #include "blank.h"
3152
3153 cdsw&ail
3154       common /stacks/ btsins, btstem
3155 C
3156       SVATS=STACK(ELEM-2)
3157       IF(STACK(ELEM).NE.1)RETURN
3158 C     STALA
3159       N=STACK(ELEM-4)
3160       IF(N.EQ.NRRE)GO TO 100
3161       IF(N.EQ.NRNONE)GO TO 200
3162 C     ZATEM : INTEGER,CHAR,BOOLEAN,TEXT
3163       SVATS=SCONST(SVATS)
3164       RETURN
3165 C ... STALA REAL
3166   100 SVATS=SCREAL(SVATS)
3167       RETURN
3168 C ... STALA NONE
3169 cdsw&ail  200 SVATS=LMEM-3
3170  200  svats = btstem - 3
3171       RETURN
3172       END
3173 C
3174       SUBROUTINE SAVEVAR(ELEM)
3175 C-------------------------------------------------------
3176 C
3177 C     ZABEZPIECZA ADRES ZMIENNEJ (UOGOLNIONEJ) Z MIEJSCA
3178 C      ELEM STOSU.
3179 C
3180 #include "stos.h"
3181 #include "blank.h"
3182 C
3183 C
3184       N=STACK(ELEM)-2
3185       GO TO (300,400,500),N
3186 C.....ZMIENNA
3187 C     ADRES PRZED KROPKA :
3188   300 CALL SAFE(STACK(ELEM-7))
3189       RETURN
3190 C.....ELEMENT TABLICY
3191 C     ADRES TABLICY :
3192   400 CALL SAFE(STACK(ELEM-2))
3193 C     I INDEKS, JESLI ROZNY OD STALEJ :
3194       IF(STACK(ELEM-2).GT.0)GO TO 300
3195 cdsw     added - bug!
3196       return
3197 C.....TABLICA STATYCZNA
3198   500 GO TO 300
3199       END
3200       SUBROUTINE SCHECK(ERROR,TYP)
3201 C--------------------------------------------------------
3202 C
3203 C     POMOCNICZA. JESLI CZUBEK STOSU NIE JEST TYPU PROSTEGO
3204 C     TYP LUB UNIWERSALNEGO - SYGNALIZUJE BLAD ERROR.
3205 C
3206 #include "stos.h"
3207 #include "blank.h"
3208 C
3209 C
3210       INTEGER ERROR,TYP
3211       I=STACK(VALTOP-4)
3212       IF(STACK(VALTOP-3).NE.0 .OR. (I.NE.NRUNIV .AND. I.NE.TYP))
3213      X      CALL SERROR(ERROR)
3214       RETURN
3215       END
3216       SUBROUTINE SNOT
3217 C-----------------------------------------------------------------
3218 C
3219 C     OBSLUGUJE OPERATOR NOT. ARGUMENT JEST NA CZUBKU .
3220 C
3221 C
3222 C     ##### OUTPUT CODE : 42 .
3223 C
3224 C     ##### DETECTED ERROR(S) : 417 .
3225 C
3226 #include "stos.h"
3227 #include "blank.h"
3228 C
3229 C
3230       CALL SNEXT
3231       CALL SVALUE
3232 C     JESLI UNIWERSALNY-POMIN
3233       IF(STACK(VALTOP).EQ.0)RETURN
3234 C     SPRAWDZ TYP
3235       CALL SCHECK(417,NRBOOL)
3236 C.....  CZY STALA?
3237       IF(STACK(VALTOP).EQ.1)GO TO 51
3238 C     NIE. CZY WB= IF.FALSE LUB IF.TRUE ?
3239       IF(WB.EQ.29 .OR. WB.EQ.30)GO TO 60
3240 C.....NIE,  WYKONAJ NOT.
3241       IDL=TSTEMP(1)
3242       CALL QUADR3(42,IDL,STACK(VALTOP-2))
3243       STACK(VALTOP)=2
3244       STACK(VALTOP-2)=IDL
3245       RETURN
3246 C.....STALA, ZMIEN WARTOSC.
3247    51 STACK(VALTOP-2)=-1-STACK(VALTOP-2)
3248       RETURN
3249 C.....NOT PRZED SKOKIEM WARUNKOWYM,ZMIEN RODZAJ SKOKU
3250    60 WB=59-WB
3251       RETURN
3252       END
3253       SUBROUTINE SARITH
3254 C--------------------------------------------------------------------------
3255 C
3256 C     1982.09.15
3257 C
3258 C     OBSLUGUJE 1 LUB 2 - ARGUMENTOWE OPERACJE ARYTMETYCZNE.
3259 C     WB=NUMER OPERACJI,      1..8 OZNACZaJA:
3260 C      ABS,MINUS UNARNY,+,-,*,/,DIV,MODE
3261 C     ARGUMENT LUB 2 ARGUMENTY SA NA CZUBKU STOSU.
3262 C     ARGUMENTY ZASTEPUJE PRZEZ WYNIK OPERACJI /UNIWERSALNY,STALA,WARTOSC/
3263 C
3264 C     WYROZNIA PRZYPADKI:
3265 C      OBA ARGUMENTY STALE,
3266 C      DODAWANIE,ODEJMOWANIE STALEJ
3267 C      MNOZENIE PRZEZ STALE 0..10,
3268 C      DZIELENIE PRZEZ 0,1,2,4,8.
3269 C
3270 C
3271 C     ##### OUTPUT CODE : 37 , 48 , 49 , 50 , 51 , 64 , 65 , 66 ,
3272 C                            67 , 68 , 69 , 70 , 71 , 72 , 73 , 74 ,
3273 C                            75 , 113 , 114 , 115 , 117 , 118 , 119 ,
3274 C                            120 , 121 , 122 , 140 .
3275 C
3276 C     ##### DETECTED ERROR(S) : 460 .
3277 C
3278 #include "stos.h"
3279 #include "option.h"
3280 #include "blank.h"
3281 cdsw&bc
3282       real y
3283       integer*2 m(2)
3284       equivalence (y, m(1))
3285 CCCCCCCCCCCCCCC
3286 C     ROBOCZE
3287       INTEGER ELEM,OPKOD
3288 C
3289       REAL   XREAL,YREAL
3290 C
3291 C
3292       INTEGER CREAL
3293 C
3294 C
3295 C........................
3296 C
3297 C     TERAZ WB=NUMER OPERACJI
3298 C     WYLICZ WARTOSC
3299       CALL SVALUE
3300 C     I WSTAW TYP PRAWEGO ARGUMENTU
3301       TRDIM=STACK(VALTOP-3)
3302       TRBAS=STACK(VALTOP-4)
3303       IDR=STACK(VALTOP-1)
3304 C.....PRZESKOCZ,JESLI OPERACJA 2-ARGUMENTOWA
3305       IF(WB.GT.2)GO TO 1000
3306 C.....ABS LUB MINUS UNARNY
3307       IF(STACK(VALTOP).EQ.0)RETURN
3308 C      ZBADAJ TYP
3309       TLDIM=TRDIM
3310       TLBAS=TRBAS
3311       IDL=IDR
3312       CALL MARITH(1)
3313 C     CZY STALA?
3314       IF(STACK(VALTOP).EQ.1)GO TO 200
3315 C     NIE. INTEGER?
3316       IF(STACK(VALTOP-4).EQ.NRINT)GO TO 150
3317 C     ZATEM ZMIENNA,WARTOSC TYPU REAL
3318 #if WSIZE == 4
3319       result = tstemp(1)
3320 #else
3321       result = tstemp(2)
3322 #endif
3323   100 CALL QUADR3(49+WB,RESULT,STACK(VALTOP-2))
3324 C     ZASTAP PRZEZ "WARTOSC" Z NOWYM RESULT
3325       STACK(VALTOP)=2
3326       STACK(VALTOP-2)=RESULT
3327       RETURN
3328 C     ZMIENNA,WARTOSC TYPU INTEGER
3329   150 RESULT=TSTEMP(1)
3330       WB=WB-2
3331       GO TO 100
3332 C     STALA JAKO ARGUMENT ABS LUB MINUSA UNARNEGO
3333   200 IF(STACK(VALTOP-4).EQ.NRRE)GO TO 250
3334       IF((WB.EQ.1 .AND. STACK(VALTOP-2).LT.0).OR.(WB.EQ.2))
3335      X          STACK(VALTOP-2)= -STACK(VALTOP-2)
3336       RETURN
3337 C     STALA REAL
3338   250 RESULT=STACK(VALTOP-2)
3339 cdsw&bc      XREAL=STALER(RESULT)
3340 #if WSIZE == 4
3341       xreal=staler(result)
3342 #else
3343       n1 = result*2-1
3344       m(1) = ipmem(n1)
3345       m(2) = ipmem(n1+1)
3346       xreal = y
3347 #endif
3348 c
3349       IF((WB.EQ.1 .AND. XREAL.LT.0.0).OR.(WB.EQ.2))
3350      X      STACK(VALTOP-2)=CREAL(-XREAL)
3351       RETURN
3352 C
3353 C................ OPERACJE 2-ARGUMENTOWE.......................
3354 C
3355 C     ROZROZNIA PRZYPADKI : OBA ARGUMENTY STALE , JEDEN ARGUMENT STALY,
3356 C       MNOZENIE LUB DZIELENIE PRZEZ WYROZNIONE STALE
3357 C                /0,1,2,3,4,5,6,7,8,9,10 LUB 0,1,2,4,8/
3358 C
3359  1000 CALL SVALU2
3360       ELEM=0
3361 C     JESLI JEDEN Z ARGUMENTOW UNIWERSALNY-ZASTAP OBA PRZEZ UNIWERSALNY
3362       IF(STACK(VALTOP)*STACK(VLPREV).EQ.0)GO TO 1400
3363 C     WSTAW TYP I NAZWE LEWEGO ,SPRAWDZ TYPY
3364       TLDIM=STACK(VLPREV-3)
3365       TLBAS=STACK(VLPREV-4)
3366       IDL=STACK(VLPREV-1)
3367       ELEM=2
3368 C      ELEM="WARTOSC",UZYWANE PO SKOKU DO 1400.
3369       OPKOD=1
3370       IF(WB.GT.6)OPKOD=2
3371       IF(WB.EQ.6)OPKOD=3
3372       CALL MARITH(OPKOD)
3373 C     WYKONAJ EWENTUALNA KONWERSJE
3374       IF(CONVR.EQ.1)CALL SVREAL(VALTOP)
3375       IF(CONVL.EQ.1)CALL SVREAL(VLPREV)
3376       IDL=STACK(VLPREV-2)
3377       IDR=STACK(VALTOP-2)
3378 C     IDL,IDR = WARTOSC LUB NUMER STALEJ LUB ATS LEWEGO,PRAWEGO ARGUMENTU.
3379 C       DLA JEDNEGO ARG.STALEGO - IDR=STALA
3380 C
3381 C
3382 C..........STALE ARGUMENTY?
3383       CALL SARGMT
3384       GO TO (2000,4000,1600,1050),ARG
3385 C
3386 C..........OBA ROZNE OD STALYCH
3387 C
3388 1050  IF(TRESLT.EQ.NRRE)GO TO 1500
3389 C
3390 C
3391 C     INTEGER
3392  1100 RESULT=TSTEMP(1)
3393  1200 OPKOD=113-3
3394 C     GENERUJ OPERACJE
3395  1300 CALL QUADR4(OPKOD+WB,RESULT,IDL,IDR)
3396 C
3397 C
3398 C.....ZASTAP OBA PRZEZ "WARTOSC" TYPU TRESLT
3399 C
3400  1400 CALL SRESULT(ELEM)
3401       RETURN
3402 C
3403 C
3404 C     REAL
3405  1500 OPKOD=119-3
3406 #if WSIZE == 4
3407       result = tstemp(1)
3408 #else
3409       result = tstemp(2)
3410 #endif
3411       GO TO 1300
3412 C
3413 C.....PRAWY ARGUMENT STALY,LEWY NIE /DLA + , * ROWNIEZ ODWROTNIE/
3414 C     JESLI REAL - WSTAW STALA I DALEJ JAK DLA OBU ROZNYCH OD STALYCH
3415  1600 IF(TRESLT.NE.NRRE)GO TO 4100
3416 C
3417 C     TUTAJ ROZSZERZENIE O ARGUMENT 0.0 LUB 1.0
3418 C
3419       IDR=SCREAL(IDR)
3420       GO TO 1500
3421 C
3422 C
3423 C.............OBA ARGUMENTY STALE. OBLICZ WYNIK.
3424 C
3425  2000 ELEM=1
3426       WB=WB-2
3427       IF(TRESLT.NE.NRINT)GO TO 3000
3428 C
3429 C.....OPERACJA NA 2 STALYCH INTEGER
3430       GO TO(2100,2200,2300,2400,2400,2500),WB
3431 C     +
3432  2100 RESULT=IDL+IDR
3433       GO TO 1400
3434 C     -
3435  2200 RESULT=IDL-IDR
3436       GO TO 1400
3437 C     *
3438  2300 RESULT=IDL*IDR
3439       GO TO 1400
3440 C     /  , DIV
3441  2400 IF(IDR.EQ.0)GO TO 4800
3442       RESULT=IDL/IDR
3443       GO TO 1400
3444 C     MODE
3445  2500 RESULT=MOD(IDL,IDR)
3446       GO TO 1400
3447 C
3448 C.....OPERACJA NA 2 STALYCH TYPU REAL
3449  3000 continue
3450 cdsw&bc      XREAL=STALER(IDR)
3451 cdsw&bc      YREAL=STALER(IDL)
3452 #if WSIZE == 4
3453       xreal=staler(idr)
3454       yreal=staler(idl)
3455 #else
3456       n1 = idr*2-1
3457       m(1) = ipmem(n1)
3458       m(2) = ipmem(n1+1)
3459       xreal = y
3460       n1 = idl*2-1
3461       m(1) = ipmem(n1)
3462       m(2) = ipmem(n1+1)
3463       yreal = y
3464 #endif
3465 C     XREAL,YREAL = WARTOSC PRAWEGO,LEWEGO ARGUMENTU
3466       GO TO (3100,3200,3300,3400),WB
3467 C     +
3468  3100 XREAL=YREAL+XREAL
3469       GO TO 3500
3470 C     -
3471  3200 XREAL=YREAL-XREAL
3472       GO TO 3500
3473 C     *
3474  3300 XREAL=YREAL*XREAL
3475       GO TO 3500
3476 C     /
3477 cailvax and all other computers: 3400 IF(YREAL.EQ. 0.0)GO TO 4800
3478  3400 if(xreal .eq. 0.0)go to 4800
3479       XREAL=YREAL/XREAL
3480 C     WSTAW XREAL DO SLOWNIKA STALYCH REAL
3481  3500 RESULT=CREAL(XREAL)
3482       GO TO 1400
3483 C
3484 C.....LEWY ARGUMENT STALY,PRAWY NIE.
3485 C
3486 C     OPERACJA SYMETRYCZNA?
3487  4000 IF(WB.EQ.3 .OR. WB.EQ.5)GO TO 4050
3488 C     OPERACJA NIESYMETRYCZNA
3489       IF(TRESLT.EQ.NRRE)GO TO 4030
3490       IDL=SCONST(IDL)
3491       GO TO 1100
3492  4030 IDL=SCREAL(IDL)
3493 C
3494 C     TUTAJ ROZSZERZENIE O LEWY ARGUMENT 0.0 DLA - , / .
3495 C
3496       GO TO 1500
3497 C
3498 C     OPERACJA SYMETRYCZNA:   + , * .ZAMIEN IDL,IDR
3499  4050 TRDIM=IDL
3500       IDL=IDR
3501       IDR=TRDIM
3502       GO TO 1600
3503 C
3504 C.....WSPOLNA AKCJA. PRAWY ARG.STALY LUB OP.SYM. I LEWY STALY
3505 C     IDL = ATS ROZNEGO OD STALEJ ARG.,IDR=STALA
3506 C         OBA ARGUMENTY TYPU INTEGER.
3507 C
3508  4100 RESULT=TSTEMP(1)
3509       GO TO (4150,4150,4300,4200,4400,4700,4700,4720),WB
3510  4150 CONTINUE
3511 C
3512 C...........
3513 C     -  . ZMIEN ZNAK STALEJ
3514  4200 IDR= -IDR
3515 C
3516 C...........
3517 C     + , - .      +0   ?
3518  4300 IF(IDR.EQ.0)GO TO 4810
3519       CALL QUADR4(37,RESULT,IDL,IDR)
3520       GO TO 1400
3521 C
3522 C..........
3523 C     *     . JAKA TO STALA?
3524  4400 IF(IDR.LT.0 .OR. IDR.GT.10)GO TO 4720
3525 C     ZATEM STALA 0..10
3526       IF(IDR-1) 4805 , 4810 , 4500
3527 C ... MNOZENIE PRZEZ STALA 2..10  /REALIZOWANE PRZEZ SHIFT/
3528  4500 OPKOD=62+IDR
3529  4600 CALL QUADR3(OPKOD,RESULT,IDL)
3530       GO TO 1400
3531 C
3532 C...........
3533 C     DIVE
3534  4700 IF(IDR.GE.0 .AND. IDR.LE.8)GO TO 4750
3535 C     WSTAW STALA
3536  4720 IDR=SCONST(IDR)
3537       GO TO 1200
3538 C ... DZIELENIE PRZEZ STALE 0..8   . WYROZNIJ 0,1,2,4,8
3539  4750 N=IDR+1
3540       GO TO (4800,4810,4820,4720,4840,4720,4720,4720,4880),N
3541 C
3542 C.....DZIELENIE PRZEZ ZERO
3543  4800 CALL SERROR(460)
3544 C     ZASTAP PRZEZ STALA ZERO / DLA MNOZENIA LUB DZIELENIA PRZEZ ZERO /
3545  4805 ELEM=1
3546       IF(.NOT.OPTOPT)CALL QUADR2(140,IDL)
3547       RESULT=IDR
3548       GO TO 1400
3549 C ... ZASTAP PRZEZ ARGUMENT ROZNY OD STALEJ / MNOZENIE,DZIELENIE
3550 C                       PRZEZ 1 LUB DODAWANIE,ODEJMOWANIE 0 /
3551  4810 RESULT=IDL
3552       GO TO 1400
3553 C
3554 C ... DIVE 2
3555  4820 OPKOD=75
3556       GO TO 4600
3557 C ... DIVE 4
3558  4840 OPKOD=74
3559       GO TO 4600
3560 C ... DIVE 8
3561  4880 OPKOD=73
3562       GO TO 4600
3563 C
3564       END
3565       SUBROUTINE SRELAT
3566 C-----------------------------------------------------------------------------
3567 C
3568 C     DWA GORNE ELEMENTY STOSU ZAWIERAJA ARGUMENTY RELACJI :
3569 C      IS , IN DLA WB= 1,2  LUB
3570 C      = , <> , < , <= , > , >=    . WB=NUMER RELACJI /3..8/
3571 C     GENERUJE KOD WYZNACZAJACY WARTOSC RELACJI.
3572 C     WYROZNIA PRZYPADKI : OBA ARGUMENTY STALE,
3573 C                          POROWNANIE ZE STALA INTEGER
3574 C                          POROWNANIE Z ZEREM  / 0 LUB 0.0 /
3575 C                          POROWNANIE Z NONE .
3576 C
3577 C
3578 C     ##### OUTPUT CODE : 55 , 56 , 76 , 77 , 78 , 79 , 80 , 81 ,
3579 C                            82 , 83 , 88 , 89 , 90 , 91 , 92 , 93 ,
3580 C                            106 , 107 , 108 , 109 , 110 , 111 ,
3581 C                            123 , 124 ,
3582 C                            125 , 126 , 127 , 128 , 129 , 130 .
3583 C
3584 C     ##### DETECTED ERROR(S) : 475 , 476 .
3585 C
3586 C
3587 #include "stos.h"
3588 #include "blank.h"
3589 C
3590 CCCCCCCCCCCCCCCCCCCCCCCC
3591       INTEGER REL(6),RELCONV(6),RLCASE,ELEM
3592 C     REL - TABLICA WYZNACZAJACA WYNIKI POROWNANIA DLA 6 RELACJI,
3593 C          BITY 15,14,13 =0 JESLI DLA L<P , L=P , L>P WYNIK JEST FALSE
3594 C     RELCONV - TABLICA ZAMIANY POROWNAN PRZY ZAMIANIE ARGUMENTOW
3595 C     RLCASE - TYP POROWNANIA: 1,3,4-INTEGER,2-REAL,5,6-REFERENCYJNY
3596 C     ELEM - RODZAJ ELEMENTU
3597       REAL   X
3598 cdsw&bc
3599       real y, yy
3600       integer*2 m(2)
3601       equivalence (y, m(1))
3602 c
3603       common/stream/ errflg,line,ibuf2(265),ibuf3(7),junk(260)
3604 C
3605       DATA RELCONV/3,4,7,8,5,6/,REL/2,5,1,3,4,6/
3606 C..........
3607       ELEM=0
3608       CALL SVALU2
3609 C     WSTAW TYP I NAZWE LEWEGO ARGUMENTU
3610       TLDIM=STACK(VLPREV-3)
3611       TLBAS=STACK(VLPREV-4)
3612       IDL=STACK(VLPREV-1)
3613 C     IS,IN ?
3614       IF(WB.LT.3)GO TO 7000
3615       CALL SVALUE
3616       IF(STACK(VALTOP)*STACK(VLPREV).EQ.0)GO TO 3200
3617 C     WSTAW TYPY ARGUMENTOW
3618       TRDIM=STACK(VALTOP-3)
3619       TRBAS=STACK(VALTOP-4)
3620       IDR=STACK(VALTOP-1)
3621       ELEM=2
3622 C     JAKA RELACJA?
3623       IF(WB.LE.4)GO TO 200
3624 C     < , <= , > , >=
3625       CALL MARITH(1)
3626       RLCASE=1
3627       IF(TRESLT.EQ.NRRE)RLCASE=2
3628       GO TO 300
3629 C     = , <>
3630 C     WSTAW INFORMACJE O DOSTEPNOSCI TYPOW FORMALNYCH
3631   200 OBJL=STACK(VLPREV-6)
3632       OBJR=STACK(VALTOP-6)
3633       CALL MEQUAL(RLCASE)
3634 C
3635 C     RLCASE OKRESLA TYP POROWNANIA: 1,3,4-INTEGER,2-REAL,5,6-REFERENCYJNE
3636   300 IF(CONVL.EQ.1)CALL SVREAL(VLPREV)
3637       IF(CONVR.EQ.1)CALL SVREAL(VALTOP)
3638       IDL=STACK(VLPREV-2)
3639       IDR=STACK(VALTOP-2)
3640 C     IDL,IDR=WARTOSC LUB NUMER STALEJ LUB ATS LEWEGO,PRAWEGO ARGUMENTU
3641       CALL SARGMT
3642 C     WYBIERZ TYP POROWNANIA: INTEGER,REAL,REFERENCYJNY
3643       GO TO (1000,3000,1000,1000,5000,5000),RLCASE
3644 C
3645 C..........INTEGER
3646 C
3647 C
3648 C     STALE ARGUMENTY?
3649  1000 GO TO (1050,1200,1500,1300),ARG
3650 C.....OBA STALE,WYZNACZ WARTOSC RELACJI
3651  1050 X=FLOAT(IDL-IDR)
3652       GO TO 3100
3653 C.....LEWY STALY,PRAWY NIE. ZAMIEN.
3654  1200 OBJL=IDL
3655       IDL=IDR
3656       IDR=OBJL
3657       WB=RELCONV(WB-2)
3658       GO TO 1500
3659 C.....LEWY ROZNY OD STALEJ.
3660 C     POROWNANIE
3661  1300 RLCASE=103
3662 C     ="POROWNANIE INTEGER"-3
3663       GO TO 1800
3664 C.....PRAWY STALY,LEWY NIE.
3665  1500 RLCASE=85
3666 C     ="POROWNANIE ZE STALA"-3
3667 C     CZY Z ZEREM?
3668       IF(IDR.EQ.0)GO TO 3400
3669 C     NIE
3670 C
3671 C.....GENERUJ POROWNANIE 2-ARG.
3672  1800 RESULT=TSTEMP(1)
3673       CALL QUADR4(RLCASE+WB,RESULT,IDL,IDR)
3674       GO TO 3200
3675 C
3676 C
3677 C..........POROWNANIE 2 ARGUMENTOW REAL
3678 C
3679  3000 RLCASE=122
3680 C     ="POROWNANIE REAL"-3
3681 cdsw      GO TO (3050,3300,4000,1800),ARG
3682 cdsw --------------------------
3683       go to (3050,3700,4000,1800),arg
3684 cdsw --------------------------
3685 C.....OBA STALE. WYZNACZ WARTOSC RELACJI
3686 cdsw&bc 3050 X=STALER(IDL)-STALER(IDR)
3687 #if WSIZE == 4
3688  3050 x=staler(idl)-staler(idr)
3689 #else
3690  3050 n1 = idl*2-1
3691       m(1) = ipmem(n1)
3692       m(2) = ipmem(n1+1)
3693       yy = y
3694       n1 = idr*2-1
3695       m(1) = ipmem(n1)
3696       m(2) = ipmem(n1+1)
3697       x = yy-y
3698 #endif
3699 c
3700  3100 IF ( X ) 3110,3120,3130
3701 C      LEWY < PRAWY
3702  3110 RESULT=IAND(REL(WB-2),1)
3703       GO TO 3150
3704 C     LEWY = PRAWY
3705  3120 RESULT=IAND(REL(WB-2),2)
3706       GO TO 3150
3707 C     LEWY > PRAWY
3708  3130 RESULT=IAND(REL(WB-2),4)
3709  3150 IF(RESULT.NE.0)RESULT=-1
3710 C     RESULT ZAWIERA REPREZENTACJE TRUE LUB FALSE
3711       ELEM=1
3712 C
3713 C
3714 C.....ZASTAP OBA ARGUMENTY PRZEZ WYNIK TYPU BOOLEAN
3715 C
3716 C
3717  3200 TRESLT=NRBOOL
3718       CALL SRESULT(ELEM)
3719       RETURN
3720 C
3721 C
3722 C.....LEWY STALY,PRAWY NIE. LEWY = 0.0 ?
3723 cdsw3300 IF(STALER(IDL).NE. 0.0)GO TO 3700
3724 C     LEWY=0.0, ZAMIEN POROWNANIA
3725 cdsw      WB=RELCONV(WB-2)
3726 cdsw      IDL=IDR
3727 C.....GENERUJ POROWNANIE 1-ARG.
3728  3400 RESULT=TSTEMP(1)
3729       CALL QUADR3(73+WB,RESULT,IDL)
3730 C     ZASTAP PRZEZ WARTOSC
3731       GO TO 3200
3732 C.....LEWY ARG. STALY<>0.0 ,WSTAW STALA
3733  3700 IDL=SCREAL(IDL)
3734       GO TO 1800
3735 C.....PRAWY STALY,LEWY NIE. PRAWY = 0.0 ?
3736 cdsw 4000 IF(STALER(IDR).EQ. 0.0)GO TO 3400
3737 C     NIE 0.0 , WSTAW STALA
3738 cdsw ---------- added -------
3739 4000  continue
3740 cdsw ------------------------
3741       IDR=SCREAL(IDR)
3742       GO TO 1800
3743 C
3744 C
3745 C
3746 C
3747 C..........REFERENCYJNE.
3748  5000 GO TO (5050,5200,5300,5600),ARG
3749 C     OBA NONE ,WSTAW TRUE DLA = , FALSE DLA <>   / -1 LUB 0 /
3750  5050 ELEM=1
3751       RESULT=WB-4
3752       GO TO 3200
3753 C.....LEWY NONE,PRAWY NIE. ZAMIEN
3754  5200 IDL=IDR
3755 C.....PRAWY NONE,LEWY NIE
3756  5300 WB=WB+6
3757       GO TO 3400
3758 C.....OBA ROZNE OD NONE. ### BEZ DYNAMICZNEJ KONTROLI TYPOW #####
3759  5600 RLCASE=120
3760 C     ="EQ REF"-3
3761       GO TO 1800
3762 C
3763 C.....RELACJA IS , IN
3764 C
3765 C     ZBADAJ TYP LEWEGO
3766  7000 IF(STACK(VLPREV).EQ.0)GO TO 7100
3767       TLBAS=IAND(IPMEM(TLBAS),15)
3768       IF((TLBAS.GT.7 .AND. TLBAS.LT.13).OR.TLDIM.GT.0)CALL MERR(475,IDL)
3769 C     ZBADAJ PRAWY : REKORD,KLASA?
3770  7100 IDL=STACK(VALTOP)
3771       IF(IDL.EQ.0)GO TO 3200
3772       IF(IDL.EQ.8.OR.IDL.EQ.9)GO TO 7200
3773       CALL SERROR(476)
3774       GO TO 3200
3775 C     O.K.   LEWY=NONE ?
3776  7200 IF(STACK(VLPREV).EQ.1)GO TO 7300
3777       ELEM=2
3778       RESULT=TSTEMP(1)
3779       CALL QUADR4(54+WB,RESULT,STACK(VLPREV-2),STACK(VALTOP-4))
3780       GO TO 3200
3781 C     LEWY=NONE : NONE IS -> FALSE , NONE IN -> TRUE
3782  7300 ELEM=1
3783       RESULT=1-WB
3784       GO TO 3200
3785       END
3786       SUBROUTINE SNEWARR
3787 C-----------------------------------------------------------------------------
3788 C
3789 C     OBSLUGUJE GENERACJE TABLICY.
3790 C     GORNE 3 ELEMENTY STOSU TO: ZMIENNA TABLICOWA,DOLNA GRANICA /UNIWERSALNY,
3791 C      STALA,WARTOSC/,GORNA GRANICA /NA CZUBKU/.
3792 C     ZDEJMUJE ZE STOSU 2 GORNE /1 ZOSTAWIA/,NIE WOLA SNEXT
3793 C
3794 C
3795 C     ##### OUTPUT CODE : 23 , 132 ,145 .
3796 C
3797 C     ##### DETECTED ERROR(S) : 433 , 435 .
3798 C
3799 #include "stos.h"
3800 #include "blank.h"
3801 C
3802 C
3803       INTEGER AUX(4)
3804 C     RUNNING-SYSTEM IDENTIFIERS OF ARRAY ELEMENTS : INTEGER,REAL,--,REFERENCE
3805 C
3806       INTEGER I,N
3807       DATA AUX / -1 , -3 , 0 , -2 /
3808 C
3809 C.....
3810       CALL SINDTYP
3811 C     STALE GRANICE?
3812       IF(STACK(VALTOP).NE.1 .OR. STACK(VLPREV).NE.1)GO TO 60
3813 C     TAK. DOLNA < GORNA ?
3814       IF(STACK(VLPREV-2).GT.STACK(VALTOP-2))
3815      X      CALL SERRO2(433,VLPREV-9)
3816 C           NAZWA 3-GO OD GORY,2-GI MA APETYT 8 /STALA/
3817    60 CONTINUE
3818 C     WSTAW GRANICE GORNA,DOLNA
3819       DO 100 I=1,2
3820         CALL QUADR4(145,SVATS(VALTOP),1,I-1)
3821 C       WSTAW WARTOSC I-TEGO PARAMETRU
3822 C       PROCEDRA STANDARDOWA GENERACJI TABLICY MA NUMER 1 I PARAMETRY:
3823 C         0 - UPPER ,1 - LOWER,2 - APETYT,3 - ADRES VIRT.NOWEJ TABLICY
3824         CALL SPOP
3825   100 CONTINUE
3826 C     OBIE GRANICE WSTAWIONE. NA CZUBKU ZMIENNA.TABLICOWA?
3827       LSTLSE=0
3828 C     IF(STACK(VALTOP).EQ.0)GO TO 30            NO GLOBAL JUMPS
3829       IF(STACK(VALTOP).EQ.0)RETURN
3830       N=STACK(VALTOP-3)
3831       IF(N.EQ.0)GO TO 300
3832 C     O.K.   WSTAW APETYT
3833       N=SAPET(N-1,STACK(VALTOP-4))
3834       N=AUX(N)
3835       CALL QUADR4(145,SCONST(N),1,2)
3836       CALL QUADR2(132,1)
3837 C     WYGENEROWANA NOWA TABLICA.ODCZYTAJ I WPISZ JEJ ADRES
3838       N=TSTEMP(4)
3839       CALL QUADR4(23,N,1,3)
3840       CALL SSTORE(VALTOP,N)
3841       RETURN
3842 C.....ERROR: ZMIENNA NIE JEST TYPU TABLICOWEGO
3843   300 CALL SERROR(435)
3844       RETURN
3845       END
3846       SUBROUTINE SRESULT(ELEM)
3847 C-----------------------------------------------------------------------------
3848 C
3849 C     POMOCNICZA. ZASTEPUJE 2 GORNE ELEMENTY STOSU PRZEZ ELEMENT
3850 C     BEZ NAZWY TYPU ELEM.
3851 C     JESLI TO NIE UNIWERSALNY,TO WSTAWIA TYP /0,TRESLT/,
3852 C     ZERUJE SLOWO -5,DO SLOWA -2 WSTAWIA RESULT
3853 C     UZYWANA DLA ZASTAPIENIA 2 ARGUMENTOW PRZEZ WYNIK /WARTOSC/ OPERACJI.
3854 C
3855 #include "stos.h"
3856 #include "blank.h"
3857
3858       CALL SPOP
3859       CALL SPOP
3860       CALL SPUSH(ELEM)
3861       STACK(VALTOP-1)=0
3862       IF(ELEM.EQ.0)RETURN
3863       STACK(VALTOP-2)=RESULT
3864       STACK(VALTOP-3)=0
3865       STACK(VALTOP-4)=TRESLT
3866       STACK(VALTOP-5)=0
3867       RETURN
3868       END
3869       SUBROUTINE SRESLT1(TYPE)
3870 C-----------------------------------------------------------------------
3871 C
3872 C     ZASTEPUJE CZUBEK STOSU PRZEZ WARTOSC TYPU <0,TYPE> ,
3873 C       BEZ NAZWY, DO SLOWA -2 WSTAWIA RESULT, ZERUJE SLOWA -5,-6
3874 C
3875 C
3876 #include "stos.h"
3877 #include "blank.h"
3878 C
3879       CALL SPOP
3880       CALL SPUSH(2)
3881       STACK(VALTOP-1)=0
3882       STACK(VALTOP-2)=RESULT
3883       STACK(VALTOP-3)=0
3884       STACK(VALTOP-4)=TYPE
3885       STACK(VALTOP-5)=0
3886       STACK(VALTOP-6)=0
3887       RETURN
3888       END
3889       SUBROUTINE SVARADR
3890 C----------------------------------------------------------------------
3891 C
3892 C     SPRAWDZA,CZY CZUBEK STOSU ZAWIERA ZMIENNA /ZMIENNA PROSTA,
3893 C       ELEMENT TABLICY,TABLICA STATYCZNA/.
3894 C     JESLI NIE, TO SYGNALIZUJE BLAD I ZASTEPUJE PRZEZ UNIWERSALNY.
3895 C     GENERUJE KOD WYLICZAJACY ADRES FIZYCZNY ZMIENNEJ.
3896 C     ATS WYLICZONEGO ADRESU ZWRACA NA ZMIENNA RESULT.
3897 C
3898 C     ##### OUTPUT CODE : 29 , 30 .
3899 C
3900 C     ##### DETECTED ERROR(S) : 420.
3901 C
3902 C
3903 #include "stos.h"
3904 #include "blank.h"
3905 C
3906 C
3907       IDL=STACK(VALTOP)
3908 C     = RODZAJ ELEMENTU
3909       IF(IDL.EQ.0)RETURN
3910       IF(IDL.GT.5)GO TO 1000
3911       GO TO (1000,1000,300,400,500),IDL
3912 C.....ZMIENNA
3913   300 N=STACK(VALTOP-2)
3914       RESULT=TSTEMP(1)
3915 C     PRZEZ KROPKE ?
3916       IF(STACK(VALTOP-7).EQ.0)GO TO 350
3917 C ... ZMIENNA PRZEZ KROPKE
3918       CALL QUADR4(29,RESULT,SMEMBER(VALTOP),N)
3919       RETURN
3920 C ... ZMIENNA WIDOCZNA
3921   350 CALL QUADR3(30,RESULT,N)
3922       RETURN
3923 C.....ELEMENT TABLICY
3924   400 RESULT=SARRAY(VALTOP)
3925       RETURN
3926 C.....TABLICA STATYCZNA
3927   500 CONTINUE
3928 C     B R A K
3929 C.....NIE ZMIENNA
3930  1000 CALL SERROR(420)
3931 C     ZASTAP PRZEZ UNIWERSALNY
3932       CALL SPOP
3933       CALL SPUSH(0)
3934       STACK(VALTOP-1)=0
3935       RETURN
3936       END
3937       SUBROUTINE SBOOLEX(N)
3938 C-----------------------------------------------------------------------------
3939 C
3940 C     OBSLUGUJE 2-ARGUMENTOWE OPERACJE BOOLOWSKIE /N=1 --> AND,
3941 C      =0 --> OR /
3942 C     2 GORNE ELEMENTY STOSU SA ARGUMENTAMI.
3943 C
3944 C
3945 C     ##### OUTPUT CODE : 100 , 101 , 140 .
3946 C
3947 C     ##### DETECTED ERROR(S) : 417 .
3948 C
3949 #include "stos.h"
3950 #include "option.h"
3951 #include "blank.h"
3952 CCCCCCCCCCCCCCCCCCCCCCC
3953       INTEGER ELEM,ANDOPR
3954 C     SKOPIUJ PARAMETR
3955       ANDOPR=N
3956       CALL SVALU2
3957       CALL SVALUE
3958 C.....USTAW TYP WYNIKU
3959       TRESLT=NRBOOL
3960 C     ZBADAJ TYPY,NAJPIERW PRAWEGO.
3961       IF(STACK(VALTOP).NE.0) CALL SCHECK(417,NRBOOL)
3962 C     SPRAWDZ LEWY ARGUMENT
3963       ELEM=0
3964       IF(STACK(VLPREV).EQ.0)GO TO 120
3965       IDR=VALTOP
3966       VALTOP=VLPREV
3967 C     TRICK
3968       CALL SCHECK(417,NRBOOL)
3969       VALTOP=IDR
3970       IF(STACK(VALTOP).EQ.0)GO TO 120
3971 C.....ZATEM OBA ARGUMENTY O.K.   ARGUMENY STALE?
3972       CALL SARGMT
3973       GO TO (170,130,160,100),ARG
3974 C     GENERUJ ZMIENNA ROBOCZA.
3975   100 RESULT=TSTEMP(1)
3976       CALL QUADR4(100+ANDOPR,RESULT,STACK(VLPREV-2),STACK(VALTOP-2))
3977 C
3978   119 ELEM=2
3979 C
3980 C.....ZASTAP PRZEZ WYNIK
3981 C
3982   120 CALL SRESULT(ELEM)
3983       RETURN
3984 C
3985 C
3986 C.....LEWY ARGUMENT STALY,PRAWY NIE.
3987 C     DALEJ BEDZIE: ELEM=ATS WARTOSCI LUB ZMIENNEJ, RESULT=WARTOSC STALEJ.
3988   130 RESULT=STACK(VLPREV-2)
3989       ELEM=STACK(VALTOP-2)
3990 C.....WSPOLNA AKCJA DLA 1 ARGUMENTU STALEGO. ELEM,RESULT - JAK WYZEJ.
3991   140 IF(ANDOPR.EQ.1 .AND. RESULT.EQ.-1 .OR.
3992      X    ANDOPR.EQ.0 .AND. RESULT.EQ.0)GO TO 150
3993 C.....AND,FALSE LUB OR,TRUE .
3994 C     ZASTAP OBA WARTOSCIA RESULT, EWENT. GENERUJ NOP.
3995       IF(.NOT.OPTOPT)CALL QUADR2(140,ELEM)
3996       ELEM=1
3997       GO TO 120
3998 C.....AND,TRUE LUB OR,FALSE. ZASTAP OBA PRZEZ ROZNY OD STALEJ ARGUMENT.
3999   150 RESULT=ELEM
4000       GO TO 119
4001 C.....PRAWY STALY,LEWY NIE.
4002   160 ELEM=STACK(VLPREV-2)
4003       RESULT=STACK(VALTOP-2)
4004       GO TO 140
4005 C.....0BA STALE
4006   170 RESULT=0
4007       ELEM=STACK(VALTOP-2)+STACK(VLPREV-2)
4008       IF(ANDOPR.EQ.1 .AND. ELEM.EQ.-2   .OR.
4009      X    ANDOPR.EQ.0 .AND. ELEM.NE.0) RESULT=-1
4010       ELEM=1
4011       GO TO 120
4012       END
4013       SUBROUTINE SARGMT
4014 C-----------------------------------------------------------------------
4015 C
4016 C     POMOCNICZA. BADA,CZY 2 GORNE ELEMENTY STOSU SA STALYMI.
4017 C     NADAJE ZMIENNEJ ARG WARTOSC :
4018 C           1 - OBA STALE
4019 C           2 - LEWY STALY,PRAWY NIE
4020 C           3 - LEWY NIE,PRAWY STALY
4021 C           4 - OBA ROZNE OD STALYCH
4022 C
4023 #include "stos.h"
4024 #include "blank.h"
4025 C
4026 C
4027       ARG=1
4028       IF(STACK(VALTOP).NE.1)ARG=2
4029       IF(STACK(VLPREV).NE.1)ARG=ARG+2
4030       RETURN
4031       END
4032       SUBROUTINE  SINDEX
4033 C-----------------------------------------------------------------------------
4034 C
4035 C     OBSLUGUJE KOLEJNY INDEKS DLA TABLICY DYNAMICZNEJ.
4036 C     WOLANA PO WYSTAPIENIU "," LUB ")"
4037 C     CZUBEK STOSU ZAWIERA INDEKS .
4038 C     PONIZEJ ADRES TABLICY .
4039 C     ZASTEPUJE 2 GORNE ELEMENTY STOSU PRZEZ  "ELEM.TABLICY"  .
4040 C
4041 C
4042 C
4043 C     ##### DETECTED ERROR(S) :  431 .
4044 C
4045 #include "stos.h"
4046 #include "option.h"
4047 #include "blank.h"
4048 C
4049       common/stream/ errflg,line,ibuf2(265),ibuf3(7),junk(260)
4050 C..................
4051       CALL SVALU2
4052 C     SPRAWDZ TYP INDEKSU
4053       CALL SINDTYP
4054       IF(STACK(VLPREV-3).GT.0)GO TO 200
4055 C     ZA DUZO INDEKSOW
4056       CALL SERRO2(431,VLPREV)
4057       GO TO 300
4058 C     O.K.
4059   200 STACK(VLPREV-3)=STACK(VLPREV-3)-1
4060 C     ZASTAP PRZEZ "ELEM.TABLICY"
4061   300 STACK(VLPREV)=4
4062       STACK(VLPREV-7)= STACK(VALTOP-2)
4063 C     WARTOSC INDEKSU. STALY?
4064       IF(STACK(VALTOP).EQ.1)STACK(VLPREV-2)= - STACK(VLPREV-2)
4065       RETURN
4066       END
4067       SUBROUTINE SINDTYP
4068 C----------------------------------------------------------------------
4069 C
4070 C     POMOCNICZA. SPRAWDZA,CZY CZUBEK STOSU ZAWIERA ELEMENT
4071 C     SPROWADZALNY DO WARTOSCI TYPU INTEGER.
4072 C     WYLICZA WARTOSC CZUBKA STOSU,DOKONUJE EWENTUALNEJ KONWERSJI DO INTEGER
4073 C     WOLANA PRZEZ PROCEDURY SINDEX,SINDXS DLA KONTROLI INDEKSU
4074 C
4075 C     ##### DETECTED ERROR(S) : 412 .
4076 C
4077 #include "stos.h"
4078 #include "blank.h"
4079 C
4080 C
4081       CALL SVALUE
4082       IF(STACK(VALTOP).EQ.0)RETURN
4083 C     NIE UNIWERSALNY,SPRAWDZ TYP
4084       N=STACK(VALTOP-4)
4085       IF(STACK(VALTOP-3).GT.0 .OR. (N.NE.NRUNIV .AND. N.NE.NRINT
4086      X           .AND. N.NE.NRRE) )GO TO 500
4087 C     O.K.
4088       IF(N.EQ.NRRE)CALL SVINT(VALTOP)
4089       RETURN
4090 C.....NIEPOPRAWNY TYP INDEKSU
4091   500 CALL SERROR(412)
4092       RETURN
4093       END
4094       SUBROUTINE SASSIGN
4095 C-----------------------------------------------------------------------------
4096 C
4097 C     WERSJA 1982.02.12
4098 C
4099 C     PROCEDURA OBSLUGUJE WIELOKROTNE PODSTAWIENIE.
4100 C     WOLANA PRZEZ SDPDA PO POJAWIENIU SIE ASSIGN.
4101 C     DOKONUJE KONTROLI TYPOW, GENERUJE KOD DYNAMICZNEJ KONTROLI
4102 C     TYPOW I KONWERSJI ORAZ KOD NADAJACY WARTOSCI LEWYM STRONOM PODSTAWIENIA.
4103 C     CZUBEK STOSU ZAWIERA PRAWA STRONE PODSTAWIENIA
4104 C     PONIZEJ ,OD LSTFOR+1 DO LSTLSE ZNAJDUJA SIE LEWE STRONY PODSTAWIENIA
4105 C    /UNIWERSALNY,ZMIENNA -MOZE BYC PRZEZ KROPKE-,ELEMTABLICY,TABL.STATYCZNA/.
4106 C     WYROZNIA PRZYPADEK PODSTAWIENIA STALEJ REPREZENTOWANEJ PRZEZ ZERA.
4107 C
4108 C     OBNIZA STOS , USTAWIA LSTLSE.
4109 C
4110 C
4111 C     ##### OUTPUT CODE :   150 , 170 .
4112 C
4113 C
4114 C
4115 #include "stos.h"
4116 #include "option.h"
4117 #include "blank.h"
4118 C
4119 CCCCCCCCCCCCCCCCCCCCC
4120       INTEGER TYPL,TYPR
4121 C     TYPL,TYPR - ATS-Y TYPOW LEWEJ,PRAWEJ STRONY /DLA KONTROLI DYNAMICZNEJ/
4122       INTEGER VALUE,J,LSE
4123 C     VALUE=ATS PRAWEJ STRONY LUB 0,GDY TO STALA REPREZENTOWANA PRZEZ ZERA
4124 C     LSE=KOLEJNA LEWA STRONA
4125 C
4126 C............................................
4127       CALL SVALUE
4128 C     JESLI BRAK LEWYCH STRON LUB CZUBEK UNIWERSALNY-OBNIZ STOS
4129        IF(STACK(VALTOP).EQ.0  .OR.  LSTLSE.LE.LSTFOR)GO TO 1000
4130 C     CZUBEK NIE JEST UNIWERSALNY,SA LEWE STRONY.
4131 C
4132 C.....OBEJRZYJ PRAWA STRONE PODSTAWIENIA
4133       TYPR=STACK(VALTOP-5)
4134       TYPL=0
4135       VALUE=SVATS(VALTOP)
4136 C
4137 C................ KONIEC PRZYGOTOWAN.  WYKONAJ W PETLI PODSTAWIENIE.
4138 C
4139   400 LSE=VLPREV
4140 C
4141 C....................POCZATEK PETLI DLA KOLEJNYCH LEWYCH STRON
4142 C     LSE WSKAZUJE KOLEJNA LEWA STRONE
4143   500 IF(STACK(LSE).EQ.0)GO TO 900
4144 C
4145 C     ZBADAJ POPRAWNOSC PODSTAWIENIA
4146       TLDIM=STACK(LSE-3)
4147       TLBAS=STACK(LSE-4)
4148       OBJL=STACK(LSE-6)
4149       IDL=STACK(LSE-1)
4150       TRDIM=STACK(VALTOP-3)
4151       TRBAS=STACK(VALTOP-4)
4152       OBJR=STACK(VALTOP-6)
4153       J=1+MSUBST(1)
4154 C     KONTROLA DYNAMICZNA?
4155       IF(J.GE.4 .AND. OPTTYP)GO TO 800
4156 C     KONWERSJA LUB KONTROLA DYNAMICZNA
4157       GO TO (800,610,620,630,640,650,660),J
4158 C
4159 C.....INTEGER:=REAL
4160   610 CALL SVINT(VALTOP)
4161       VALUE=STACK(VALTOP-2)
4162 C     JESLI STALA - WSTAW DO TABLICY SYMBOLI
4163       IF(STACK(VALTOP).EQ.1)VALUE=SCONST(VALUE)
4164       GO TO 800
4165 C
4166 C.....REAL:=INTEGER
4167   620 CALL SVREAL(VALTOP)
4168       VALUE=STACK(VALTOP-2)
4169 C     JESLI STALA - WSTAW DO TABLICY SYMBOLI
4170       IF(STACK(VALTOP).EQ.1)VALUE=SCREAL(VALUE)
4171       GO TO 800
4172 C
4173 C.....OBIE STRONY ZNANEGO TYPU
4174   630 CALL QUADR3(150,VALUE,STACK(LSE-4))
4175       GO TO 800
4176 C
4177 C.....TYP LEWEJ FORMALNY,PRAWEJ ZNANY
4178   640 IF(TYPR.EQ.0)TYPR=STYPST(VALTOP)
4179       GO TO 660
4180 C
4181 C.....TYP LEWEJ ZNANY,PRAWEJ FORMALNY
4182   650 TYPL=STYPST(LSE)
4183       GO TO 700
4184 C
4185 C.....TYPY OBYDWU STRON FORMALNE
4186   660 TYPL=STYPFT(LSE)
4187       GO TO 700
4188 C
4189 C
4190 C..........KONTROLA DYNAMICZNA: TYPL,TYPR - TYPY LEWEJ,PRAWEJ STRONY
4191   700 CALL QUADR4(170,TYPL,VALUE,TYPR)
4192 C
4193 C.....WPISZ WARTOSC
4194 C
4195   800 CALL SSTORE(LSE,VALUE)
4196 C....................ZAKONCZENIE PETLI:
4197 C     CZY JEST KOLEJNE LSE?
4198   900 J=STACK(LSE)
4199       LSE=LSE-STCKAP(J)
4200       IF(LSE.GT.LSTFOR)GO TO 500
4201 C.................... OBNIZANIE STOSU
4202  1000 CONTINUE
4203  1020 CALL SPOP
4204       IF(VALTOP.GT.LSTFOR)GO TO 1020
4205       LSTLSE=0
4206       RETURN
4207       END
4208