C Loglan82 Compiler&Interpreter C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw C Copyright (C) 1993, 1994 LITA, Pau C C This program is free software; you can redistribute it and/or modify C it under the terms of the GNU General Public License as published by C the Free Software Foundation; either version 2 of the License, or C (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. File: LICENSE.GNU C =============================================================== SUBROUTINE AL1 C----------------------------------------------------------------------- C C 1983.01.06 C C * * * * * * * * * * * * * * * * * * * * C C THE FOLLOWING FILE UNITS ARE USED : C C 1 - INTERACTIVE INPUT FROM THE TERMINAL ( FOR TESTING ONLY ) C 2 - INTERACTIVE OUTPUT TO THE TERMINAL ( FOR TESTING ONLY ) C 13 - LISTING OUTPUT ( TEST MESSAGES ) C 14 - WORKING FILE SCRATCH - CODE FROM PARSER AND L-CODE C ( USED ONLY VIA SEEK,PUT,GET WITH IBUF3 ) C 15 - L-CODE OUTPUT ( TEXTUAL (HEXADECIMAL) REPRESENTATION C OF SYMBOL TABLE AND L-CODE ) C C * * * * * * * * * * * * * * * * * * * * C C STRUMIENIE : C 3 - BINARNY - KOD Z PARSERA C LO - WYDRUKI KONTROLNE /ZNAKOWY/ C 3 - PRODUKOWANE CZWORKI /BINARNY/ - SEKWENCYJNIE, C OD REKORDU NUMER IOP(2)+1 . C /REKORD O NUMERZE IOP(2) BUFORUJE STOS "CASE"/ C C * * * * * * * * * * * * * * * * * * * * C C C C C ##### OUTPUT CODE : 200 . C C C #include "stos.h" #include "blank.h" C COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260) LOGICAL ERRFLG C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM C COMMON/SUMMARY/FREE COMMON/CASE/DEEP,OVER C C cdeb --------------- added ------------ common /brid/breaklid c breaklid - numer w displayu (dla interpretera) procedury breakl common /debug/deb,breakt(500),brnr,maxbr logical deb cdeb ----------------------------------- common/MJLMSG/IERC,MSG cdsw ---------------------------- integer*4 msg cdsw ---------------------------- cdsw&bc common /stacks/ btsins, btstem C C IERC=0 msg = 'al1 ' C CALL STEST C WCZYTANA OPCJA WYDRUKOW KONTROLNYCH CALL SABORT C WYLAPANIE ABORTU C C LSTWRD=LMEM-260 C OSTATNIE ZAJETE SLOWO W BUFORZE WYJSCIOWYM / LMEM-259 .. LMEM-1 / BOTTOM=LMEM-916 STACK(BOTTOM)=-1 C DNO STOSU / LMEM-916 .. LMEM-516 / Z WARTOWNIKIEM = -1 FREE=LMEM-516-BOTTOM C ROZMIAR STOSU = 400 DEEP=LMEM-600 C PUSTY STOS INSTRUKCJI "CASE" / LMEM-515 .. LMEM-260 / QRECNR=IOP(2) C NAJWIEKSZY UZYTY NUMER REKORDU STRUMIENIA 3 C cdsw&bc btsins = lpml btstem = lpmf cdsw ----------------- added ---------------------------------- c inicjalizacje zmiennych z common przeniesione z podprogramow c przeniesione z sinit stckag = 0 stcka0 = 8 do 1 i=1,14 stckap(i) = 8 1 continue stckap(5) = 10 stckap(6) = 4 apetyt(1) = 1 #if WSIZE == 4 apetyt(2) = 1 #else apetyt(2) = 2 #endif apetyt(3) = 3 apetyt(4) = 2 c przeniesione z scase over = 0 cdsw ----------------------------------------------------------------- c CALL SPASS2 C cdeb ----------------- added ------------------- c instrukcja L-kodu przekazujaca breaklid if (.not.deb) go to 2001 call quadr1(211) if(breaklid.eq.0) go to 2001 call quadr2(210,breaklid) 2001 continue cdeb ------------------------------------------- C C WYPISZ ZNACZNIK KONCA PRODUKOWANEGO KODU POSREDNIEGO CALL QUADR1(200) C JESLI TRZEBA - WYPISZ BUFOR Z CZWORKAMI IF(ERRFLG) GO TO 2000 IF(LSTWRD.EQ.LMEM-260)GO TO 1000 cdsw **************************** cdsw QRECNR=QRECNR+1 cdsw CALL SEEK(IBUF3,QRECNR) cdsw CALL PUT(IBUF3,IPMEM(LMEM-259)) cbc write(18) (ipmem(i),i=lmem-259,lmem-4) call ffwrite_ints(18, ipmem(lmem-259), 256) cbc cdsw ***************************** C C C WRITE HEXADECIMAL REPRESENTATION OF SYMBOL TABLE AND L-CODE 1000 CALL SLCSTOUT 2000 CONTINUE call ffclose(18) C CLOSED TEMPORARY 18 should BE AUTOMATICALLY DELETED but ... call ffunlink(18) C C C WYLACZ 'RECOVERY' CALL SRCVOFF C C C.....PRZYGOTUJ DANE STATYSTYCZNE C C IPMEM(ISFIN-3)=QRECNR-IOP(2) C = LICZBA WYPRODUKOWANYCH REKORDOW Z KODEM POSREDNIM IPMEM(ISFIN-4)=(400-FREE)/4 C = % UZYTEGO STOSU /WZOR POPRAWNY DLA ROZMIARU = 400 / C C cdsw MSG=HAL1 CALL MESS C PRINT LISTING CALL ML2 C STOP C PO ABORCIE /BLAD W KOMPILATORZE/ C7777 ERRFLG=.TRUE. CHANGED TO COMMENT 04.01.84 CBC GO TO 1000 END SUBROUTINE SPASS2 C----------------------------------------------------------------------------- C C PROCEDURA STERUJACA PRZEBIEGIEM 2. C DWUKROTNIE PRZECHODZI PRZEZ WSZYSTKIE MODULY. C FAZA 1 : WYLICZANIE WARTOSCI STALYCH /INIT=TRUE/ C - WYBIERA TYLKO MODULY ZAWIERAJACE STALE WYLICZANE C FAZA 2 : WLASCIWA GENERACJA KODU /INIT=FALSE/ C - PRZECHODZI PRZEZ WSZYSTKIE MODULY ZAWIERAJACE INSTRUKCJE C W OBU FAZACH PRZECHODZI KOLEJNO PRZEZ MODULY I DLA KAZDEGO MODULU C WSTAWIA JEGO ADRES DO P ,WCZYTUJE PIERWSZY REKORD Z KODEM POSREDNIM, C USTAWIA WB I INDEKS SYMBOLU DLA SNEXT,INICJALIZUJE STRUKTURY DANYCH, C WOLA SDPDA. C C STARTUJE OD BLOKU WSKAZANEGO PRZEZ NBLUS. C DLA KAZDEGO MODULU REKORDY Z KODEM POSREDNIM Z PARSERA POWIAZANE C SA W LISTE : SLOWO +8 ZAWIERA NUMER PIERWSZEGO REKORDU /JESLI SLOWO C +9 =0 TO LISTA JEST PUSTA/ A SLOWO +9 INDEKS PIERWSZEGO SYMBOLU C W REKORDZIE. SLOWO 256 REKORDU ZAWIERA NUMER NASTEPNEGO REKORDU C LISTY. KOD DLA KAZDEGO MODULU JEST ZAKONCZONY PARA . C C SLOWO +2 W OPISIE MODULU ZAWIERA ADRES /W IPMEM/ NASTEPNEGO MODULU. C #include "stos.h" #include "blank.h" COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260) LOGICAL ERRFLG C COMMON/TEST/TESTC,TESTS,TESTH LOGICAL TESTC,TESTS,TESTH C LOGICAL INIT C = TRUE DLA FAZY WYLICZANIA STALYCH C C INTERNAL 2000 CHANGED TO COMMENT 04.01.84 C PUNKT POWROTU PO PRZEPELNIENIU STOSU W SPUSH C C C................. FAZA WYLICZANIA STALYCH C /PIERWSZE PRZEJSCIE PRZEZ KOD DLA MODULOW/ C INIT=.TRUE. C C.....USTAW P NA BLOK GLOWNY 100 P=NBLUS C C C.....INICJALIZACJA DLA PROTOTYPU P 1000 CONTINUE IF(.NOT.TESTC) GOTO 5000 call ffputcs(13,' ------------ PASS2 ---------- P =') call ffputi (13,P,6) call ffputnl(13) 5000 CONTINUE C POMIN,JESLI TO PROTOTYP FORMALNY/PROC.,FUN.,SYGNAL/ IF(IAND(ISHFT(IPMEM(P),-4),15).NE.0)GO TO 2000 C C ... PODCZAS WYLICZANIA STALYCH POMIN,JESLI MODUL ICH NIE MA IF(INIT.AND.IPMEM(P-1).EQ.0)GO TO 2000 C C POMIN , JESLI NIE MA INSTRUKCJI IF(IPMEM(P+9).EQ.0)GO TO 2500 C C ... ODSZUKAJ PIERWSZY REKORD Z KODEM POSREDNIM N=IPMEM(P+8) C WSTAW NUMER I WCZYTAJ PIERWSZY REKORD IX(258)=N CALL SEEK(IBUF3,N) IF(.NOT.TESTC) GOTO 6000 call ffputcs(13,' REKORD') call ffputi (13,N,5) call ffputcs(13,' SYMBOL') call ffputi (13,IPMEM(P+9),4) call ffputnl(13) 6000 CONTINUE CALL GET(IBUF3,IX) WB=IPMEM(P+9) C WSTAW INDEKS BIEZACEGO SYMBOLU,USTAW WB IX(257)=WB WB=IX(WB) C INICJALIZACJA CALL MPROTO CALL SDPDA(INIT) CALL MPROTC C...........WEZ NASTEPNY MODUL 2000 P=IPMEM(P+2) IF(P.NE.0)GO TO 1000 C WSZYSTKIE MODULY JUZ SKOMPILOWANE. C C................. FAZA GENERACJI KODU C /DRUGIE PRZEJSCIE PRZEZ KOD DLA MODULOW/ C IF(.NOT.INIT)RETURN INIT=.FALSE. GO TO 100 C C C.....MODUL BEZ INSTRUKCJI. PREFIKS? 2500 IDL=IPMEM(P+21) IF(IDL.EQ.0)GO TO 2600 C TAK. PRZEPISZ INFORMACJE O INSTRUKCJACH PO INNER IPMEM(P-7)=IPMEM(IDL-7) GO TO 2000 C ... BEZ PREFIKSU. DLA KLASY,REKORDU WSTAW: BRAK INSTR. PO INNER 2600 IF(IAND(IPMEM(P),15).NE.1)IPMEM(P-7)=0 cdsw&bc if (.not. init) call stclass GO TO 2000 END subroutine stclass implicit integer(a-z) #include "blank.h" c c not yet used as prefix ipmem(p+1) = 0 c begin of module call quadr2(184, p) c begin of instructions call quadr1(179) c inner call quadr2(178, ipmem(p+23)) c after inner label call quadr2(181, 1) c fin call quadr1(194) c lastwill call quadr1(174) ipmem(p+8) = 0 c back call quadr1(193) c end module call quadr1(185) return end SUBROUTINE SDPDA(INICJA) C----------------------------------------------------------------------------- C C WERSJA 1983.03.09 C C GLOBAL JUMPS ARE CHANGED TO LOCAL JUMPS IF POSSIBLE OTHERWISE THEY ARE C CHANGED TO COMPUTED JUMPS 8.5.84 C C MAIN ROUTINE OF SEMANTIC ANALYSIS AND CODE GENERATION C GLOWNA PROCEDURA ANALIZY SEMANTYCZNEJ I GENERACJI KODU POSREDNIEGO C /CZWOREK/ DLA MODULU. C PRACUJE JAK DETERMINISTYCZNY AUTOMAT ZE STOSEM STEROWANY SYMBOLEM C WEJSCIOWYM. C W ZALEZNOSCI OD WB /SYMBOL WEJSCIOWY/ WYBIERANA JEST AKCJA DO WYKONANIA C O ETYKIECIE 100*WB : OD 100 DO 7200. C WB MUSI MIEC NADANA WARTOSC PRZED WYWOLANIEM SDPDA. C C DLA KAZDEGO MODULU WOLANA DWUKROTNIE: C PIERWSZY RAZ W FAZIE WYLICZANIA STALYCH /O ILE MODUL ZAWIERAL C STALE WYLICZANE/ I DRUGI RAZ W FAZIE GENERACJI KODU /O ILE C BYLY INSTRUKCJE/. C W FAZIE WYLICZANIA STALYCH PO WYSTAPIENIU ZNACZNIKA PIERWSZEJ C INSTRUKCJI ZASTEPUJE W PROTOTYPIE ADRES POCZATKU KODU DLA MODULU C PRZEZ NUMER REKORDU I MIEJSCE W REKORDZIE ZAWIERAJACE TEN ZNACZNIK. C C C C ##### OUTPUT CODE : 15 , 23 , 31 , 33 , 34 , 35 , 36 , 41 , C 85 , 132 , 145 , 149 , 151 , 152 , C 172 , 173 , 176 , 177 , 178 , 179 , C 181 , 182 , 186 , 187 . C C C ##### DETECTED ERROR(S) : 407 , 410 , 411 , 414 , 415 , 416 , C 418 , 420 , 421 , 422 , 423 , 424 , 426 , 427 , C 428 , 429 , 430 , 440 , 444 , 449 , 454 , 604 . C C #include "stos.h" #include "option.h" #include "blank.h" C C STACK - STOS DLA ANALIZY SEMANTYCZNEJ. OD LEWEJ WKLADANE SA C ELEMENTY,OD PRAWEJ OPISY PARAMETROW OUTPUT. C KAZDY ELEMENT STOSU ZAJMUJE KILKA KOLEJNYCH SLOW C OZNACZANYCH -9,...,-1,0. ZEROWE SLOWO OKRESLA RODZAJ C ELEMENTU. C OPISY PAR. OUTPUT ZAJMUJA ZAWSZE 12 SLOW: -9,..,+2 C STOS /400 SLOW + WARTOWNIK/ ZAJMUJE W TABLICY IPMEM C SLOWA OD BOTTOM = LMEM-916 DO LMEM-516 C ELEMENTY STOSU : C 0 - UNIWERSALNY C 1 - STALA C 2 - WARTOSC C 3 - ZMIENNA C 4 - ELEMENT TABLICY DYN. C 5 - TABLICA STATYCZNA C 6 - OPIS PETLI "FOR" C 7 - NAZWA TYPU C 8 - REKORD C 9 - KLASA C 10 - BLOK PREFIKSOWANY C 11 - PROCEDURA C 12 - FUNKCJA C 13 - SYGNAL C 14 - OPERATOR C BOTTOM - WSKAZUJE DNO STOSU / WARTOWNIKA = -1 / C VALTOP - CZUBEK STOSU /INDEKS ZEROWEGO SLOWA/ C VLPREV - INDEKS ZEROWEGO SLOWA POPRZEDNIEGO ELEMENTU C STCKAG,STCKA0,STCKAP - TABLICA -1..14 APETYTOW ELEMENTOW STOSU C /TZN. STCKAP(I)=APETYT ELEMENTU TYPU I/ C STCKAP(-1)= 0 =APETYT WARTOWNIKA DLA POP C APETYT - TABLICA OKRESLAJACA DLA KAZDEGO RODZAJU TYPU JEGO C APETYT. 1,2,3,4 --> 1,2,3,2 C LSTFOR - INDEKS OSTATNIEGO SLOWA ZAJETEGO PRZEZ PETLE FOR C LSTLSE - " " LSE NA STOSIE /LSE ,TZN. LEWE STRONY C PODSTAWIENIA SA UMIESZCZONE POWYZEJ LSTFOR DO LSTLSE/ C KIND - RODZAJ WOLANEGO MODULU: 0-ZWYKLY,1-VIRTUALNY,2-FORMALNY C PHADR - ATS ADRESU FIZYCZNEGO POLA DANYCH GENEROWANEGO OBIEKTU C LUB 0 ,GDY ADR.FIZYCZNY TRZEBA ODTWORZYC Z ADR.VIRT. C LASTPR - JESLI NA STOSIE JEST FUNKCJA,PROCEDURA,KLASA,REKORD, C SYGNAL,BLOK PREF. , DLA KTOREGO PAMIETANY JEST TYLKO C ADRES POSREDNI ZAMIAST PELNEGO ADR.VIRTUALNEGO, TO C LASTPR= INDEKS TEGO ELEMENTU; INACZEJ ZERO C FSTOUT - INDEKS PIERWSZEGO SLOWA ZAJETEGO PRZEZ OPISY PAR. C OUTPUT C WB - BIEZACY SYMBOL /WEJSCIOWY/ KODU POSREDNIEGO C RESULT - ATS WYNIKU OPERACJI C CONSNR - TABLICA ZAWIERAJACA ADRESY /INDEKSY W IPMEM/ TYPOW: C BOOLEAN,CHAR,INTEGER,NONE,REAL,STRING I UNIWERSALNEGO . C LSTSAF - OSTATNI ELEMENT STOSU NIE WYMAGAJACY ZABEZPIECZENIA C PRZEZ SAFEST ,USTAWIA SAFEST,OBNIZA SPOP. C TEMPNR - POCZATEK ADRESOW W /BUDOWANEJ/ TABLICY SYMBOLI C UZYWANYCH DLA ATRYBUTOW ROBOCZYCH, C ADRESY WIEKSZE ZAREZERWOWANE DLA PETLI FOR, C ZMNIEJSZANE O 6 NA POCZATKU, A ZWIEKSZANE NA KONCU C PETLI. C LSTEMP - NAJMNIEJSZY UZYTY ADRES ATRYBUTU ROBOCZEGO C C QRECNR - OSTATNI UZYTY NUMER REKORDU W STRUMIENIU 3 C BUFOR NA GENEROWANY KOD POSREDNI WYSYLANY NA STRUMIEN 3 C ZAJMUJE 259 SLOW W TABLICY IPMEM : OD LMEM-259 DO LMEM-1 . C LSTWRD - INDEKS OSTATNIEGO ZAJETEGO SLOWA W BUFORZE. C C ZASADA WYPELNIANIA BUFORA : SA CO NAJMNIEJ 4 WOLNE SLOWA C / LSTWRD < LMEM-4 / . PROCEDURY QUADR1 .. QUADR4 C DOPISUJA ZA LSTWRD SWOJE ARGUMENTY I ZWIEKSZAJA LSTWRD. C JESLI POZOSTANA MNIEJ NIZ 4 SLOWA - WOLAJA QDROUT. C QDROUT WYPISUJE PIERWSZE 256 SLOW I OSTATNIE 3 SLOWA C PRZEPISUJE NA POCZATEK, ZMNIEJSZAJAC LSTWRD O 256. C FRSTTS - PIERWSZE SLOWO W IPMEM NA NOWE OPISY ATRYBUTOW C W TABLICY SYMBOLI C ZAPELNIANIE TABLICY SYMBOLI: TSINSE --> <-- TSTEMP C OBSZAR WOLNY - FRSTTS .. LSTEMP-1 C UNIT - RODZAJ BIEZACEGO MODULU: C 1 - BLOK C 2 - HANDLER C 3 - BLOK PREFIKSOWANY C 4 - PROCEDURA C 5 - FUNKCJA C 6 - KLASA C INNER = 0 - NIE BYLO "INNER",ALE JEST LEGALNY C 1 - WYSTAPIENIE "INNER" BEDZIE NIELEGALNE C 2 - JUZ WYSTAPIL C 4 - LAST-WILL WYSTAPIENIE INNER NIELEGALNE C LSTWILL - TRUE,JESLI WYSTAPILO LAST WILL C C TEST - OPCJA / U3 / WYDRUKOW KONTROLNYCH , C = 0 --> BEZ WYDRUKOW , <> 0 --> WYDRUKI C C ARG - INFORMACJA O STALYCH ARGUMENTACH /USTAWIANA PRZEZ C SARGMT/ : C 1 - OBA STALE C 2 - LEWY STALY,PRAWY NIE C 3 - LEWY NIE,PRAWY STALY C 4 - OBA ROZNE OD STALYCH C ATLINE - NUMER LINII, W KTOREJ PRZEBIEG MA SIE ZAWIESIC C C FILE - ADRES PLIKU NA STOSIE LUB 0 DLA OPERACJI NA PLIKU C STANDARDOWYM C C FLARGS - INFORMACJA O PRZETWORZONYCH ARGUMENTACH OPERACJI C WE/WY : C 0 - NIE WYSTAPIL ZADEN ARGUMENT C 1 - WYSTAPIL TYLKO ADRES PLIKU C 2 - WYSTAPIL CO NAJMNIEJ 1 ARGUMENT C ( LUB READLN/WRITELN ) C C FLREADY - TRUE, JESLI (R6-12) ZAWIERA ADRES PLIKU, ZAPALANE PRZEZ C SFLADR, GASZONE PRZEZ SCALLB I DLA 'I-O-END' C C FLMODF - PRZELACZNIK NUMERU PROCEDURY STANDARDOWEJ UZYWANY C DLA WE/WY : 1 DLA PLIKU STANDARDOWEGO C 0 DLA WSKAZYWANEGO C NUMERY PROCEDUR WE/WY (ROZNE PUNKTY WEJSCIA) SA C POWIAZANE : C INPUT : N-1 C WSKAZYWANY : N C OUTPUT : N+1 C C............. C COMDECK OPT? 04.01.84 C COMMON/OPTION/OPTMEM,OPTOPT,OPTIND,OPTTYP,OPTTRC,OPTCSC,OPTCSF C LOGICAL OPTOPT,OPTTYP,OPTTRC C FROM LOGLAN.08 C C ***** OPCJE KOMPILATORA ***** C C OPTMEM - 0 - TRZEBA ROBIC MEMBER C 1 - NIE TRZEBA ROBIC MEMBER C OPTOPT - .TRUE. - WOLNO OPTYMALIZOWAC C .FALSE. - NIE WOLNO C OPTIND - 0 - KONTROLA INDEKSOW DLA TABLIC C 2 - BEZ KONTROLI INDEKSOW C OPTTYP - .TRUE. - BEZ DYNAMICZNEJ KONTROLI TYPOW C C OPTTRC - .TRUE. - KOMPILAT POWINIEN ZAWIERAC SLEDZENIE C C OPTCSC - 1 - BEZ KONTROLI ZAKRESU DLA "CASE" C 0 WYMAGANA KONTROLA C OPTCSF - 0 - SZYBKI "CASE" C 1 - PAMIECIOOSZCZEDNY C C C................ C C*COMDECK BLANKSEM C LOGICAL INSYS, OWN C COMMON /BLANK/ IOP(4), C X P, C X TLDIM, TLBAS, IDL, OBJL, C X TRDIM, TRBAS, IDR, OBJR, C X TRESLT, C X TRESLT, C X CONVL, CONVR, C X NRPAR, C X IX (261), C X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF , C X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT, C X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS , C X LOCAL, OWN, OBJECT, C X IPMEM(5000) C REAL STALER(100) C INTEGER STACK(5000) C EQUIVALENCE(STALER(1),IPMEM(1)) C EQUIVALENCE(STACK(1),IPMEM(1)) C......COMDECK BLANKSEM C FROM LOGLAN.08 17.01.84 C LMEM - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I IPMEM C C CZESC SEMANT C P - PROTOTYP AKTUALNY C TLDIM - LICZBA ARRAY OF W TYPIE LEWEGO ARGUMENTU C TLBAS - TYP BAZOWY LEWEGO ARGUMENTU C DISPL - .TRUE. JESLI LEWY ARGUMENT JEST DOSTEPNY PRZEZ C DISPLAY C OBJL - PROTOTYP OBIEKTU, Z KTOEGO POCHODZI TEN ATRYBUT C IDL - IDENTYFIKATOR LEWEGO ARGUMENTU (DO SYGNALIZACJI BLE- C DOW) C TRDIM, TRBAS, DISPR, IDR, OBJR - ANALOGICZNIE DLA PRAWEGO ARGU- C MENTU C TRESLT - TYP BAZOWY WYNIKU OPERACJI ARYTMETYCZNEJ C CONVL, CONVR - FLAGA KONWERSJI LEWEGO I PRAWEGO ARGUMENTU C OPERACJI ARYTMETYCZNYCH LUB RELACJI C WARTOSCI : C 0 - BRAK KONWERSJI C 1 - KONWERSJA DO REAL C 2 - KONWERSJA DO INTEGER (?) C NRPAR - NUMER PARAMETRU (PROCEDURA MPKIND) C C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW C C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ- C NACZONEGO NA PROTOTYPY SYSTEMOWE C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM C C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER C NRRE - REAL C NRBOOL - BOOLEAN C NRCHR - CHARACTER C NRCOR - COROUTINE C NRPROC - PROCESS C NRTEXT - STRING (TEXT) C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1) C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY C REFERENCYJNY) C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA C C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE- C MOWEJ C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT C BYL LOKALNY C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU) C OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO C SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL) C C COMMON/STREAM/ ERRFLG,LINE,IBUF23(272),JUNK(260) LOGICAL ERRFLG LOGICAL MLOCTP,MDISTP C C COMMON/TEST/TESTC,TESTS,TESTH LOGICAL TESTC,TESTS,TESTH cdsw&bc real y integer*2 m(2) equivalence (y, m(1)) cdsw&bc common /stacks/ btsins, btstem C C LOGICAL INICJA C INICJA=.TRUE. W FAZIE WYLICZANIA WARTOSCI STALYCH SYMBOLICZNYCH I GRANIC C TABLIC STATYCZNYCH. C C C INTEGER ERROR C ERROR=NUMER BLEDU DLA WSPOLNEJ SYGNALIZACJI /9900/ C LOGICAL FORSTP C DLA PETLI "FOR" : TRUE --> WYSTAPILO "STEP", FALSE --> NIE WYSTAPILO C C C C AUXILIARY VARIABLES INTEGER ATS,ELEM,I,IND C C.....INICJALIZACJA cdsw&bc FRSTTS=LPMEM+1 frstts = btsins c C =INDEKS POCZATKU TABLICY SYMBOLI - CZESC DLA ATRYBUTOW DEKLAROWANYCH IPMEM(LMEM)=BOTTOM-1 C OSTATNIE SLOWO IPMEM ZAWIERA INDEKS PIERWSZEGO OD PRAWEJ WOLNEGO C SLOWA NA POMOCNICZY SLOWNIK DLA WYZNACZANIA ADRESOW ATRYBUTOW C DEKLAROWANYCH W TABLICY SYMBOLI. C C C CONSNR(1)=NRBOOL CONSNR(2)=NRCHR CONSNR(3)=NRINT CONSNR(4)=NRNONE CONSNR(5)=NRRE CONSNR(6)=NRTEXT CONSNR(7)=NRUNIV cdsw&bc consnr(8)=-17 IF(INICJA)GO TO 10 CALL SINIT 10 VALTOP=BOTTOM VLPREV=BOTTOM LSTLSE=BOTTOM LSTFOR=BOTTOM LASTPR=0 LSTSAF=BOTTOM FSTOUT=BOTTOM+401 cdsw&bc TEMPNR=LMEM-6 tempnr = btstem-6 c LSTEMP=TEMPNR FILE=0 FLARGS=0 FLREADY=.FALSE. FLMODF=1 ICOUNT=0 OCOUNT=0 GO TO 50 C C C 30 CALL SPOP 40 CALL SNEXT C.....GLOWNA PETLA. W ZALEZNOSCI OD SYMBOLU Z WEJSCIA WYBIERZ AKCJE 50 CONTINUE GO TO(100,200,300,400,500,600,700,800,900,1000,1100,1200,1300, X 1400,1500,1600,1700,1800,1900,2000,2100,2200,2300,2400,2500, X 2600,2700,2800,2900,3000,3100,3200,3300,3400,3500,3600,3700, X 3800,3900,4000,4100,4200,4300,4400,4500,4600,4700,4800,4900, X 5000,5100,5200,5300,5400,5500,5600,5700,5800,5900,6000,6100, X 6200,6300,6400,6500,6600,6700,6800,6900,7000,7100,7200,7300, X 7400,7500,7600,7700,7800,7900,8000,8100,8200,8300,8400,8500, X 8600,8700,8800,8900,9000,9100,9200,9300,9400),WB cbc X 8600,8700,8800,8900,9000),WB cbc X 8600,8700,8800),WB C C---------------- AND -------------------------- C 100 CALL SBOOLEX(1) GO TO 40 C C--------------- ARRAY OF ------------------------ C C ZWRACA : SLOWO -2 =0 - TYP STATYCZNY (-3),(-4) C SLOWO -2 >0 - ATS ZMODYFIKOWANEGO TYPU FORMALNEGO C 200 CALL SNEXT C WB=LICZBA ARRAY OF C CZY NA CZUBKU JEST KLASA,REKORD LUB NAZWA TYPU? ELEM=STACK(VALTOP) IF(ELEM.EQ.0)GO TO 40 IF(ELEM.LT.7 .OR. ELEM.GT.9)GO TO 250 C OK. WPISZ LICZBE ARRAY OF STACK(VALTOP-3)=WB C CZY TYP FORMALNY? IF(STACK(VALTOP-2).NE.0) CALL SMODIFY(STACK(VALTOP-2),WB) GO TO 40 C.....NIEPOPRAWNY CZUBEK STOSU 250 ERROR=440 GO TO 9900 C C--------------- ASSIGN -------------------------- C C CZUBEK STOSU POWINIEN ZAWIERAC WARTOSC,PONIZEJ SA LSE /POWYZEJ LSTFOR DO C 300 CALL SASSIGN GO TO 40 C C--------------- ASSIGN CONST -------------------- C CZUBEK STOSU POWINIEN ZAWIERAC STALA /WARTOSC WYRAZENIA DEFINIUJACEGO/, C PONIZEJ CZUBKA JEST STALA DEFINIOWANA,MAJACA W SLOWIE -2 INDEKS C SWOJEGO OPISU W IPMEM. C C STALA? 400 IF(STACK(VLPREV).EQ.0 .OR. STACK(VALTOP).EQ.0)GO TO 420 IF(STACK(VALTOP).EQ.1)GO TO 410 CALL SERRO2(429,VLPREV) GO TO 420 C POBIERZ ADRES OPISU STALEJ DEFINIOWANEJ 410 ELEM=STACK(VLPREV-2) C WPISZ WARTOSC I TYP IPMEM(ELEM-1)=STACK(VALTOP-2) IPMEM(ELEM-4)=0 IPMEM(ELEM-3)=STACK(VALTOP-4) 420 CALL SPOP GO TO 30 C C--------------- ATTACH -------------------------- C CZUBEK STOSU POWINIEN ZAWIERAC REFERENCJE C 500 CALL SATTACH LSTEMP=TEMPNR GO TO 30 C C--------------- BLOCK --------------------------- C WYSTAPIENIE BLOKU O NUMERZE WN 600 CALL SNEXT CALL QUADR2(186,IPMEM(WB)) LSTEMP=TEMPNR GO TO 40 C C--------------- CALL ---------------------------- C NA PEWNO BLAD: PROCEDURA SAMA "ZJADA" CALL. C 700 CALL SERROR(422) GO TO 30 C C--------------- CASE ---------------------------- 800 CALL SCASE GO TO 30 C WRACA DO ETYKIETY 30 C--------------- CASE LABEL ---------------------- 900 CALL SCSLAB GO TO 30 C WRACA DO ETYKIETY 30 C--------------- COMA ---------------------------- C C PONIZEJ CZUBKA JEST : C UNIWERSALNY LUB ELEMENT TABLICY/DYN./ LUB TABLICA STATYCZNA C LUB REKORD,KLASA,BLOK PREF.,PROCEDURA,FUNKCJA. C NA CZUBKU JEST INDEKS LUB PARAMETR AKTUALNY. C PO OBSLUZENIU WOLA SNEXT C 1000 ELEM=STACK(VLPREV) C JESLI UNIWERSALNY-OMIN IF(ELEM.EQ.0)GO TO 30 C CZY TO PARAMETR? IF(ELEM.GT.7)GO TO 1050 C NIE,MOZE TABLICA STATYCZNA? IF(ELEM.EQ.5)GO TO 1060 C ZATEM TABLICA DYNAMICZNA /ELEMENT TABLICY/ CALL SINDEX GO TO 30 1050 CALL SPARAM GO TO 40 1060 CALL SINDXS GO TO 40 C C--------------- CONST:BOOL,CHAR,INT,NONE,REAL,STRING ----- C 1100 CONTINUE 1200 CONTINUE 1300 CONTINUE 1500 CONTINUE 1600 ELEM=WB-10 CALL SNEXT C.....WSPOLNA AKCJA DLA WSZYSTKICH STALYCH,ROWNIEZ NONE 1650 CALL SPUSH(1) STACK(VALTOP-1)=0 STACK(VALTOP-2)=WB STACK(VALTOP-3)=0 STACK(VALTOP-4)=CONSNR(ELEM) STACK(VALTOP-5)=0 GO TO 40 C.....WYROZNIONY POCZATEK DLA NONE 1400 ELEM=4 WB=0 GO TO 1650 C C C--------------- COPY ---------------------------- C NA CZUBKU STOSU JEST WARTOSC DO SKOPIOWANIA. C 1700 CALL SVALUE C JESLI UNIWERSALNY-POMIN IF(STACK(VALTOP).EQ.0)GO TO 40 C ZBADAJ TYP. POMIN NONE. ELEM=STACK(VALTOP-4) IF( ELEM.EQ.NRNONE) GO TO 40 C MOZE TO TABLICA? IF(STACK(VALTOP-3).GT.0)GO TO 1750 C NIE. CZY TYP PIERWOTNY? DO 1730 I=1,6 IF(CONSNR(I).EQ.ELEM)GO TO 1790 1730 CONTINUE C.....ZATEM O.K. 1750 ATS=TSTEMP(4) CALL QUADR3(41,ATS,STACK(VALTOP-2)) STACK(VALTOP)=2 STACK(VALTOP-2)=ATS GO TO 40 C.....NIE REFERENCJA 1790 ERROR=415 GO TO 9900 C C--------------- DETACH -------------------------- C 1800 CALL QUADR1(187) LSTEMP=TEMPNR GO TO 40 C C--------------- DOT ------------------------------ C 1900 CALL SNEXT C WB=IDENT CALL SNEXT C WB = NAZWA PO KROPCE CALL SVALUE IF(STACK(VALTOP).NE.0)GO TO 1910 C UNIWERSALNY.IDENT ZASTAP PRZEZ UNIWERSALNY Z NAZWA PO KROPCE STACK(VALTOP-1)=WB GO TO 40 C O.K. 1910 I=STACK(VALTOP-4) C I=KWALIFIKACJA WARTOSCI PRZED KROPKA IND=MDOT(STACK(VALTOP-3),I,STACK(VALTOP-1),WB) ATS=STACK(VALTOP-2) C ATS=WARTOSC PRZED KROPKA CALL SPOP C DALEJ JAK DLA WIDOCZNEGO IDENTYFIKATORA GO TO 2805 C--------------- DOWNTO -------------------------- 2000 CALL SFORTO(.FALSE.,FORSTP) GO TO 40 C POWROT DO ETYKIETY 40 C--------------- SIGN ---------------------------- 2100 CALL SVALUE ELEM=STACK(VALTOP) IDL=STACK(VALTOP-2) IF(ELEM.EQ.0)GO TO 40 IF(STACK(VALTOP-3).GT.0)GO TO 2110 ATS= +1 IF(STACK(VALTOP-4).EQ.NRINT)GO TO 2130 IF(STACK(VALTOP-4).EQ.NRRE)GO TO 2150 C ... NIEPOPRAWNY TYP ARGUMENTU SIGN 2110 ERROR=604 GO TO 9900 C ... INTEGER. STALA ? 2130 IF(ELEM.NE.1)GO TO 2160 IF(IDL.LT.0) ATS= -1 IF(IDL.EQ.0) ATS= 0 GO TO 2170 C ... REAL. STALA ? 2150 IF(ELEM.NE.1)GO TO 2160 cdsw&bc IF(STALER(IDL).LT. 0.0) ATS= -1 cdsw&bc IF(STALER(IDL).EQ. 0.0) ATS= 0 #if WSIZE == 4 if(staler(idl) .lt. 0.0) ats= -1 if(staler(idl) .eq. 0.0) ats= 0 #else n1 = idl*2-1 m(1) = ipmem(n1) m(2) = ipmem(n1+1) if(y .lt. 0.0) ats= -1 if(y .eq. 0.0) ats= 0 #endif c GO TO 2170 C ... GENERUJ KOD 2160 ATS=TSTEMP(1) CALL QUADR3(31,ATS,IDL) C ZASTAP PRZEZ WARTOSC STACK(VALTOP)=2 2170 STACK(VALTOP-1)=0 STACK(VALTOP-2)=ATS STACK(VALTOP-4)=NRINT GO TO 40 C--------------- ESAC ---------------------------- 2200 CALL SESAC GO TO 40 C--------------- FIN ----------------------------- C 2300 CALL SEND RETURN C C C--------------- FIRSTINSTR ---------------------- C C JESLI TO FAZA WYLICZANIA STALYCH - ZAPAMIETAJ TO MIEJSCE I KONCZ. C 2400 IF(INICJA)GO TO 2450 CALL SNEXT C PIERWSZA INSTRUKCJA MODULU, WB=NUMER INSTRUKCJI CALL QUADR1(179) LINE=WB GO TO 40 C C ... KONIEC WYLICZANIA STALYCH DLA TEGO MODULU 2450 IPMEM(P+8)=IX(258) IPMEM(P+9)=IX(257) RETURN C--------------- FOR END ------------------------- C 2500 CALL SFOREND GO TO 30 C POWROT DO ETYKIETY 30 C--------------- FOR VARIABLE -------------------- C C PISZ : KONIEC BLOKU BAZOWEGO /BY UNIKNAC PONOWNEGO PRZYDZIALU C TYCH SAMYCH ATRYBUTOW ROBOCZYCH W JEDNYM BLOKU/ 2600 CALL QUADR1(176) C ZAREZERWUJ 2 NUMERY DLA ATRYBUTOW ROBOCZYCH DLA PETLI FOR TEMPNR=TEMPNR-6 IF(FRSTTS.GE.LSTEMP)CALL SSTOVF C C LSTEMP=TEMPNR C C C ... ZMIENNA PROSTA? IND=STACK(VALTOP) IF(IND.EQ.0)GO TO 40 ERROR=410 C ="OCZEKIWANA ZMIENNA PROSTA" IF(IND.NE.3 .OR. STACK(VALTOP-7).NE.0)GO TO 9900 C TAK. INTEGER? CALL SCHECK(411,NRINT) LSTLSE=VALTOP GO TO 40 C--------------- FROM ---------------------------- C 2700 CALL SINDTYP FORSTP=.FALSE. GO TO 40 C--------------- IDENTYFIKATOR ------------------- C WB=IDENT , WN=NAZWA ZE SCANNERA 2800 CALL SNEXT IND=MIDENT(WB) ATS=0 C..........WSPOLNE ROZPOZNANIE I OBSLUGA DLA IDENTYFIKATORA PRZEZ KROPKE C LUB WIDOCZNEGO. C IND = ADRES ZEROWEGO SLOWA OPISU ROZPOZNANEGO IDENTYFIKATORA C ATS= ATS WARTOSCI PRZED KROPKA /I=KWALIFIKACJA/ LUB ZERO C 2805 ELEM=SWHAT(IND) C WLOZ NA STOS , WPISZ NAZWE , WEZ KOLEJNY SYMBOL CALL SPUSH(ELEM) STACK(VALTOP-1)=WB CALL SNEXT C FAZA WYLICZANIA STALYCH ? IF(INICJA)GO TO 2850 C NIE. C JESLI TO "UNIWERSALNY"-NIC NIE ROB IF(ELEM.EQ.0)GO TO 50 2807 STACK(VALTOP-6)=0 STACK(VALTOP-7)=ATS STACK(VALTOP-5)=0 C NAZWA TYPU? IF(ELEM.EQ.7)GO TO 2880 IF(ELEM.GT.5)GO TO 2870 C.....STALA,ZMIENNA,TABLICA STATYCZNA. WSTAW TYP. STACK(VALTOP-4)=IPMEM(IND-3) C STALA? IF(ELEM.NE.1)GO TO 2815 C....."STALA" STACK(VALTOP-3)=0 IF(.NOT.INICJA)STACK(VALTOP-2)=IPMEM(IND-1) C WSTAWIONY TYP,WARTOSC STALEJ GO TO 50 C....."ZMIENNA","TABLICA STATYCZNA" 2815 STACK(VALTOP-3)=IPMEM(IND-4) STACK(VALTOP-2)=IND IF(ATS.EQ.0)STACK(VALTOP-2)=TSINSE(IND,LOCAL) C WSTAWIONY ATS C.....TYPU FORMALNEGO? ELEM=STACK(VALTOP-4) 2820 ELEM=IAND(IPMEM(ELEM),15) C ELEM=POLE T TYPU ZMIENNEJ IF(ELEM.NE.6)GO TO 2830 C A WIEC TYP FORMALNY. PRZEZ KROPKE? IF(ATS.NE.0)GO TO 2825 C.....PRZEZ DISPLAY STACK(VALTOP-6)=OBJECT C CZY TYP DOSTEPNY PRZEZ DISPLAY? IF(MDISTP(IPMEM(IND-1),STACK(VALTOP-4),ELEM))GO TO 2823 C TYP NIEDOSTEPNY PRZEZ DISPLAY,WSTAW SL ZMIENNEJ STACK(VALTOP-5)= - IPMEM(IND-1) GO TO 2830 C TYP DOSTEPNY PRZEZ DISPLAY,WSTAW WARSTWE 2823 STACK(VALTOP-5)=ELEM GO TO 2830 C.....PRZEZ KROPKE. TYP JEST LOKALNYM ATRYBUTEM? 2825 STACK(VALTOP-5)= -1 IF(MLOCTP(STACK(VALTOP-4),I))STACK(VALTOP-5)= +1 C.....TYP JUZ WSTAWIONY 2830 IF(STACK(VALTOP).EQ.3)GO TO 50 IF(STACK(VALTOP).EQ.12)GO TO 2875 C....."TABLICA STATYCZNA" CONTINUE C NA RAZIE B R A K GO TO 50 C C ... W FAZIE WYLICZANIA STALYCH 2850 IF(ELEM.LT.2)GO TO 2860 C NIELEGALNY OBIEKT W WYRAZENIU DEFINIUJACYM STALA. ERROR=429 GO TO 9901 2860 IF(ELEM.EQ.0)GO TO 50 C STALA DEFINIOWANA ? /TAK,JESLI WB = "LSE" / IF(WB.NE.39)GO TO 2865 C TAK. WSTAW DO SLOWA -2 ADRES OPISU STALEJ STACK(VALTOP-2)=IND GO TO 50 C STALA W WYRAZENIU DEFINIUJACYM. WSTAW DO SLOWA -2 WARTOSC C / DLA REAL - NUMER STALEJ / 2865 STACK(VALTOP-2)=IPMEM(IND-1) C CZY STALA MA JUZ OKRESLONA WARTOSC ? IF(IPMEM(IND-3).NE.0)GO TO 2807 C TYP = 0 /SLOWO -3/ OZNACZA,ZE STALA JESZCZE NIE MIALA OKRESLONEJ C WARTOSCI ERROR=430 GO TO 9901 C C.....REKORD,KLASA,PROCEDURA,FUNKCJA,SYGNAL,OPERATOR. 2870 ELEM=IPMEM(IND-3) STACK(VALTOP-4)=IND STACK(VALTOP-3)=0 IDR=STACK(VALTOP)-7 C DLA FUNKCJI ZBADAJ CZY TYP FORMALNY GO TO (2872,2872,2872,2875,2820,2875,2890),IDR C C ... KLASA,REKORD . NEW ? 2872 STACK(VALTOP-2)=0 C - TYP STATYCZNY IF(WB.EQ.40)GO TO 2873 C LEWY NAWIAS? IF(WB.NE.36)GO TO 50 C BRAK NEW PRZED LEWYM NAWIASEM CALL SERROR(423) GO TO 2874 C NEW 2873 CALL SNEXT 2874 CALL SCALLB GO TO 50 C ... PROCEDURA,SYGNAL, C.D. DLA FUNKCJI C JESLI WB ROZNE OD "," LUB ")" - WYWOLAJ /INACZEJ-PODEJRZEWAJ PARAMETR/ 2875 IF(WB.NE.10 .AND. WB.NE.54)GO TO 2874 GO TO 50 C....."NAZWA TYPU" /PARAMETR FORMALNY "TYPE"/ 2880 STACK(VALTOP-3)=0 STACK(VALTOP-4)=IND C PRZEZ KROPKE? IF(ATS.NE.0)GO TO 2885 C PRZEZ DISPLAY STACK(VALTOP-2)=TSINSE(IND,LOCAL) C ZERO ARRAY OF,TYP FORMALNY,ATS TEGO TYPU STACK(VALTOP-6)=OBJECT GO TO 50 C.....PARAMETR "TYPE" PRZEZ KROPKE C ODCZYTAJ TYP 2885 STACK(VALTOP-2)=TSTEMP(2) CALL QUADR4(85,STACK(VALTOP-2),SMEMBER(VALTOP),IND) GO TO 50 C.....OPERATOR, JESLI WB ROZNE OD "(" - BLAD 2890 ERROR=454 C = NIELEGALNE WYSTAPIENIE NAZWY OPERATORA IF(WB.NE.36)GO TO 9901 GO TO 50 C--------------- IF-FALSE , IF-TRUE ---------------- 2900 CONTINUE 3000 CALL SVALUE IND=WB-29 C IND= 1 DLA IF-TRUE , = 0 DLA IF-FALSE CALL SNEXT C NA CZUBKU WARTOSC TYPU BOOLEAN? CALL SCHECK(407,NRBOOL) C STALA? IF(STACK(VALTOP).EQ.1)GO TO 3050 CALL QUADR3(151+IND,STACK(VALTOP-2),WB) GO TO 30 C SKOK PRZY STALEJ WARTOSCI WYRAZENIA 3050 IF(IND+STACK(VALTOP-2).NE.0) GOTO 30 C ZATEM TRUE, IF TRUE FALSE, IF FALSE CALL SPOP GOTO 3350 C C------ INNER -------- C LOKALNE WYSTAPIENIE 3100 IF (INNER.NE.0) CALL MERR(424+INNER,0) INNER = 2 CALL QUADR2(178,IPMEM(P+23)) C ZAZNACZ: INSTRUKCJE PO INNER IPMEM(P-7) = P LSTEMP = TEMPNR GOTO 40 C C------- INSTREND-------- C 3200 CALL SNEXT LINE= WB CJF IF (LINE.EQ.ATLINE) CALL STOPAT(ATLINE) CALL SNEXT C JESLI BYLY BLEDY CZYSC STOS IF (ERRFLG) GOTO 10 IF (INICJA) GOTO 50 C C C PRZY ZGASZONEJ OPCJI "OPTIMALIZATION" LUB "SYSPP" ZAKONCZ BLOK BAZOWY IF(OPTOPT.AND.IPMEM(NBLSYS+4).EQ.0)GO TO 3250 LSTEMP=TEMPNR CALL QUADR1(176) C C PRZY WYLACZONEJ OPCJI "TRACE" WYPISZ UJEMNY NUMER 3250 ELEM=LINE IF(.NOT.OPTTRC)ELEM=-LINE CALL QUADR2(177,ELEM) GO TO 50 C--------------- JUMP ----------------------------------- 3300 CALL SNEXT 3350 CALL QUADR2(182,WB) LSTEMP=TEMPNR GO TO 40 C--------------- KILL ---------------------------- C CZUBEK POWINIEN ZAWIERAC WARTOSC REFERENCYJNA C 3400 CALL SKILL GO TO 30 C C--------------- LABEL ---------------------------- 3500 CALL SNEXT C WYPISZ ETYKIETE CALL QUADR2(181,WB) LSTEMP=TEMPNR GO TO 40 C--------------- LEFT PARANTHESIS ---------------- C 3600 IF(STACK(VALTOP).LT.8)CALL SVALUE GO TO 40 C C--------------- ---------------------------- 3700 CONTINUE GO TO 40 C--------------- LOWINDEX ------------------------ C NA CZUBKU POWINIEN BYC ELEMENT SPROWADZALNY DO WARTOSCI INTEGER 3800 CALL SINDTYP GO TO 40 C--------------- LSE ----------------------------- C NA CZUBKU POWINNA BYC LEWA STRONA PODSTAWIENIA: UNIWERSALNY, C ZMIENNA,ELEM. TABLICY,TABLICA STATYCZNA LUB - DLA INICJALIZACJI- C STALA DEFINIOWANA C 3900 LSTLSE=VALTOP ELEM=STACK(VALTOP)+1 IF(ELEM.GT.6)GO TO 3980 GO TO(40,3910,3980,40,40,40),ELEM C.....STALA. LEGALNE TYLKO PODCZAS INICJALIZACJI. 3910 IF(INICJA)GO TO 40 C.....BLAD. 3980 ERROR=420 C ZASTAP PRZEZ UNIWERSALNY I OBSLUZ OD NOWA GO TO 9901 C C--------------- NEW ----------------------------- C NA PEWNO BLAD: KLASA /REKORD/ SAMA "ZJADA" NEW C 4000 ERROR=421 GO TO 9900 C C--------------- NEWARRAY ------------------------ C 4100 CALL SNEWARR GO TO 30 C C--------------- NOT ----------------------------- C 4200 CALL SNOT GO TO 50 C C--------------- OPERATION ----------------------- C 4300 CALL SNEXT C WB=NUMER OPERACJI CALL SARITH GO TO 40 C C--------------- OPTION -------------------------- C 4400 CALL SOPTION GO TO 40 C C--------------- OR ------------------------------ C 4500 CALL SBOOLEX(0) GO TO 40 C C--------------- OTHERWISE ------------------------- C 4600 CALL SOTHER GO TO 40 C C--------------- PREFBLOCK ------------------------- C 4700 CALL SNEXT CALL SPUSH(10) STACK(VALTOP-1)=0 STACK(VALTOP-7)=0 STACK(VALTOP-4)=IPMEM(WB) CALL SNEXT CALL SCALLB GO TO 50 C--------------- PRIMITIVE TYPE ------------------ C 4800 CALL SNEXT CALL SPUSH(7) STACK(VALTOP-1)=0 STACK(VALTOP-2)=0 STACK(VALTOP-3)=0 STACK(VALTOP-4)=CONSNR(WB) GO TO 40 C C--------------- QUA ----------------------------- C 4900 CALL SVALUE CALL SNEXT IF(STACK(VALTOP).EQ.0)GO TO 40 TLDIM=STACK(VALTOP-3) TLBAS=STACK(VALTOP-4) IDL=STACK(VALTOP-1) STACK(VALTOP-4)=MAQUAB(WB) CALL QUADR3(149,STACK(VALTOP-2),STACK(VALTOP-4)) GO TO 40 C C--------------- I-O-END ------------------------- C C WYSTAPILY ARGUMENTY ? 5000 IF(FLARGS.LT.2)CALL MERR(444,0) IF(FILE.NE.0)CALL SPOP FILE=0 FLARGS=0 FLREADY=.FALSE. FLMODF=1 GO TO 40 C C--------------- RELATION ------------------------ C 5100 CALL SNEXT C WB=NUMER RELACJI CALL SRELAT GO TO 40 CBC added C--------------- RESUME -------------------------- C 5200 call sresum LSTEMP=TEMPNR GO TO 30 C C--------------- RETURN -------------------------- C 5300 LSTEMP=TEMPNR CALL SRETURN cbc GO TO 40 goto 50 C C--------------- RIGHT PARENTHESIS ------------- C 5400 IF(STACK(VLPREV).LT.8)GO TO 1000 C KONIEC WYWOLANIA CALL SPARAM CALL SNEXT CALL SCALLE GO TO 50 C C--------------- START ------------------------- C 5500 CONTINUE GO TO 40 C C--------------- STEP --------------------------- 5600 CALL SINDTYP FORSTP=.TRUE. cdsw&bc c check if constant step if (stack(valtop) .ne. 1) goto 5601 c yes, error if step < 0 if (stack(valtop-2) .lt. 0) call serror(479) goto 40 5601 continue c not constant c generate code to check if step >= 0 call quadr2(240, stack(valtop-2)) c GO TO 40 C C--------------- STOP -------------------------- C 5700 CONTINUE cbc... call quadr1(221) c...bc GO TO 40 C C--------------- THIS -------------------------- C 5800 CALL SNEXT C WB=NAZWA PO 'THIS' C WEZ Z DISPLAYA ADR.VIRTUALNY,WSTAW NA STOS WARTOSC CALL SPUSH(2) STACK(VALTOP-1)=WB STACK(VALTOP-2)=TSTEMP(4) STACK(VALTOP-4)=MTHIS(WB) CALL QUADR3(15,STACK(VALTOP-2),STACK(VALTOP-4)) STACK(VALTOP-3)=0 STACK(VALTOP-5)=0 GO TO 40 C C--------------- TO ---------------------------- 5900 CALL SFORTO(.TRUE.,FORSTP) GO TO 40 C C--------------- WAIT --------------------------- C 6000 CONTINUE GO TO 40 C C--------------- WRITE --------------------------- C6100 CALL SWRITE cdsw 6100 CALL SWRITE(*30,*40) C POWROT DO ETYKIETY 30 LUB 40 cdsw ----------------------------- 6100 call swrite(whdsw) go to(30,40),whdsw cdsw ----------------------------- C C--------------- WRITELN ------------------------- 6200 CALL SFLADR FLARGS=2 CALL QUADR2(132,58+FLMODF) GO TO 40 C C--------------- BOUNDS ---------------------------- C 6300 CONTINUE GO TO 40 C C--------------- LOWER , UPPER ---------------------- C C CZUBEK STOSU ZAWIERA ADRES TABLICY 6400 CONTINUE 6500 CALL SVALUE C WARTOSC TABLICOWA? ERROR=416 IF(STACK(VALTOP-3).EQ.0)GO TO 9900 C O.K. RESULT=TSTEMP(1) CALL QUADR3(2*WB-95+OPTMEM,RESULT,STACK(VALTOP-2)) C ZASTAP PRZEZ WARTOSC INTEGER CALL SRESLT1(NRINT) GO TO 40 C C--------------- LOCK , UNLOCK --------------------- C 6600 CONTINUE 6700 IDL=WB-33 C = NUMER PROCEDURY STANDARDOWEJ LOCK,UNLOCK 6710 CALL SVARADR C PRZEKAZ ADRES ZMIENNEJ CALL QUADR4(145,RESULT,IDL,0) C WYWOLAJ PROCEDURE CALL QUADR2(132,IDL) C ZBADAJ TYP : SEMAPHORE ? IDR=STACK(VALTOP-4) IF(STACK(VALTOP-3).GT.0.OR.IAND(IPMEM(IDR),15).NE.9) X CALL SERROR(418) C DLA LOCK,UNLOCK TO JUZ WSZYSTKO IF(WB.NE.68)GO TO 30 C ... TEST&SET . ODCZYTAJ WARTOSC REsULT=TSTEMP(1) CALL QUADR4(23,RESULT,IDL,1) C ZASTAP PRZEZ WARTOSC CALL SRESLT1(NRBOOL) GO TO 40 C--------------- TEST&SET -------------------------- 6800 IDL=38 GO TO 6710 C C--------------- WIND , TERMINATE ------------------ C C NIELEGALNE POZA HANDLEREM 6900 CONTINUE 7000 IF(UNIT.EQ.2)GO TO 7050 CALL MERR(427,0) GO TO 40 C O.K. 7050 CALL QUADR1(103+WB) GO TO 40 C C--------------- RAISE ----------------------------- C C NA PEWNO BLAD: SYGNAL SAM "ZJADA" RAISE. 7100 CALL SERROR(449) GO TO 30 C C--------------- LAST-WILL ------------------------- C C ZAKONCZ INSTRUKCJE MODULU 7200 CALL SFIN LSTWILL=.TRUE. C INNER BEDZIE NIELEGALNY INNER=4 C WYPISZ ETYKIETE LAST-WILL CALL SLWILL GO TO 40 C C--------------- READ ---------------------------- cdsw 7300 CALL SREAD(*30,*40) cdsw ------------------------------- 7300 call sread(whdsw) go to(30,40),whdsw cdsw -------------------------------- C POWROT DO ETYKIETY 30 LUB 40 C--------------- READLN -------------------------- 7400 CALL SFLADR FLARGS=2 CALL QUADR2(132,42-FLMODF) GO TO 40 C C--------------- PUT ----------------------------- C7500 CALL SPUT cdsw 7500 CALL SPUT(*30,*40) C POWROT DO ETYKIETY 30 LUB 40 cdsw --------------------------- 7500 call sput(whdsw) go to (30,40),whdsw cdsw --------------------------- C C--------------- GET ----------------------------- C7600 CALL SGET cdsw 7600 CALL SGET(*30,*40) cdsw -------------------------- 7600 call sget(whdsw) go to (30,40),whdsw cdsw --------------------------- C POWROT DO ETYKIETY 30 LUB 40 C C--------------- OPEN2 --------------------------- 7800 CALL SVALUE ATS=SVATS(VALTOP) C CZUBEK POWINIEN ZAWIERAC NAZWE PLIKU (arrayof char) cbc CALL SCHECK(414,NRTEXT) if (stack(valtop-3) .ne. 1) goto 7801 n = stack(valtop-4) if (n .ne. nrchr) goto 7801 cfile CALL QUADR4(145,ATS,73,1) cfile ------------------------- call quadr4(145,ats,73,2) cfile -------------------------- CALL SPOP C DALEJ JAK DLA OPEN1 C C--------------- OPEN1 --------------------------- cfile 7700 N=STACK(VALTOP) cfile ----------- added ------------------------ c wspolna obsluga c nowa postac OPEN: OPEN(f,T,nazwa) - proc.stand. 73 c OPEN(f,T) - proc.stand. 72 c T okresla rodzaj operacji. Dozwolone: integer, real ,boolean, char, text c zmiana w interpreterze dla procedur standardowych 72 i 73: c parametr 0: output, adres nowego obiektu typu file c parametr 1: rodzaj operdcji () zalezy do T): c 1-text, 2-char, 3-int, 4-real, 5-direct c parametr 2: nazwa ( tylko dla 73) c c stos zawiera na czubku T, ponizej F c 7700 continue c nazwa typu pierwotnego? if(stack(valtop).ne.7) go to 7702 c legalne nazwy typu: text, char ,integer, real n = stack(valtop-4) c n - ident. typu if(n.eq.nrtext) go to 7701 if(n.eq.nrint) go to 7705 if(n.eq.nrre) go to 7706 if(n.eq.nrchr) go to 7708 cbc if (n .eq. -17) goto 7709 c error - nie nazwa typu lub nielegalny typ 7702 call serror(419) go to 7715 c nrtext 7701 n = 1 go to 7710 c nrint 7705 n = 3 go to 7710 c nrreal 7706 n = 4 go to 7710 c nrchr 7708 n = 2 goto 7710 cbc 7709 n = 5 7710 n = sconst(n) call quadr4(145,n,wb-5,1) 7715 call spop c n = stack(valtop) cfile ------------------------------------- C ZMIENNA ? IF(N.GT.2 .AND. N.LT.6)GO TO 7720 CALL SERROR(420) GO TO 30 C TYPU 'FILE' 7720 CALL SFTEST CALL QUADR2(132,WB-5) ATS=TSTEMP(4) CALL QUADR4(23,ATS,WB-5,0) CALL SSTORE(VALTOP,ATS) GO TO 30 7801 call serror(416) goto 30 C C--------------- EOF0 ---------------------------- C C = EOF(INPUT) 7900 CALL SEOF0(39) GOTO 40 C C--------------- EOF1 ---------------------------- 8000 CALL SEOF(40) GO TO 40 C WRACA BEZPOSREDNIO DO ETYKIETY 40 C C--------------- PAR. INPUT ---------------------- C UNIMPLEMENTED 8100 CONTINUE C PARAMETR INPUT WSTAWKI W ASSEMBLERZE C8100 CALL SNEXT C WB = NUMER REJESTRU. C.D. DLA IN-OUT C8150 CALL SVALUE C WPISZ NUMER REJESTRU DO SLOWA -1 C STACK(VALTOP-1)=SREGSTR(WB) C ICOUNT=ICOUNT+1 C GO TO 40 C C--------------- PAR. OUTPUT --------------------- C UNIMPLEMENTED 8200 CONTINUE C PARAMETR OUTPUT WSTAWKI W ASSEMBLERZE C8200 CALL SOUTPAR C ZDEJMIJ ZE STOSU C GO TO 30 C C--------------- PAR. INOUT ---------------------- C UNIMPLEMENTED 8300 CONTINUE C PARAMETR IN-OUT WSTAWKI W ASSEMBLERZE C NAJPIERW OBSLUZ JAK PAR.OUTPUT, POTEM JAK PAR.INPUT C8300 CALL SOUTPAR C GO TO 8150 C C--------------- ASSEMBLER ----------------------- C UNIMPLEMENTED 8400 CONTINUE C WSTAWIANY TEKST W ASSEMBLERZE C8400 CALL SBODY C GO TO 40 C C--------------- EOLN0 --------------------------- C 8500 CALL SEOF0(74) GO TO 40 C C--------------- EOLN1 --------------------------- C 8600 CALL SEOF(75) GO TO 40 C C-------- THIS-COROUTINE ---------------------------- C 8700 N=NRCOR C WLOZ NA STOS 'WARTOSC' 8720 CALL SPUSH(2) ATS=TSTEMP(4) STACK(VALTOP-1)=0 STACK(VALTOP-2)=ATS STACK(VALTOP-3)=0 STACK(VALTOP-4)=N STACK(VALTOP-5)=0 C ODCZYTAJ WARTOSC : FUNKCJA STANDARDOWA 76,77 CALL QUADR2(132,WB-11) CALL QUADR4(23,ATS,WB-11,0) GO TO 40 C C--------- THIS-PROCESS ---------------------------- C 8800 N=NRPROC GO TO 8720 C c--------- putrec ----------------------------------- c 8900 call spgrec(83) goto 30 c c--------- getrec ----------------------------------- 9000 call spgrec(82) goto 30 c cbc added concurrent statements c--------- enable ----------------------------------- 9100 call sconc(223) goto 40 c c--------- disable ---------------------------------- 9200 call sconc(224) goto 40 c c--------- accept ----------------------------------- 9300 call sconc(225) goto 40 c--------- procedure list end ----------------------- c error - skip and read next symbol 9400 goto 40 c C------------------------------------------------------ C C..........WSPOLNA OBSLUGA BLEDOW. ERROR=NUMER BLEDU. C ZASTAPIENIE CZUBKA STOSU PRZEZ UNIWERSALNY Z ZACHOWANIEM NAZWY. C WRACA NA POCZATEK PETLI. 9900 CALL SNEXT 9901 CALL SERROR(ERROR) ELEM=STACK(VALTOP-1) CALL SPOP CALL SPUSH(0) STACK(VALTOP-1)=ELEM GO TO 50 END SUBROUTINE SINIT C------------------------------------------------------ C C POMOCNICZA. INICJALIZACJA SLOWNIKA ATRYBUTOW, C ZMIENNYCH UNIT,INNER,LSTWILL C NIE JEST WOLANA W FAZIE WYLICZANIA STALYCH. C C DLA KLAS WSTAWIA DO SLOWA +1 ZERO. C JESLI MODUL MA PREFIKS,WSTAWIA DO SLOWA +1 PREFIKSU 1. C C ##### OUTPUT CODE : 184 . C C #include "stos.h" #include "blank.h" C INTEGER AUX0(8),AUX(7) EQUIVALENCE (AUX0(2),AUX(1)) DATA AUX0/1,3,5,5,4,4,3,2/ C = RODZAJ MODULU W ZALEZNOSCI OD POLA "S" ZEROWEGO SLOWA C cdsw DATA STCKAG,STCKA0,STCKAP /0,8,8,8,8,8,10,4,8,8,8,8,8,8,8,8/ cdsw X ,APETYT /1,2,3,2/ C C C.....JAKI TO MODUL ? LSTWILL=.FALSE. INNER=1 N=IPMEM(P) C SPRAWDZ POLE "S" : BITY 5..7 UNIT=IAND(ISHFT(N,-8),7) UNIT=AUX(UNIT) C MOZE KLASA ? /JESLI POLE "T",BITY 12..15, <> 1 / IF(IAND(N,15).EQ.1)GO TO 100 C KLASA UNIT=6 INNER=0 100 CONTINUE C.....ZAZNACZ : JESZCZE NIE UZYWANY JAKO PREFIKS IPMEM(P+1)=0 IF(UNIT.LT.3)GO TO 200 C JESLI MA PREFIKS - ZAZNACZ DLA PREFIKSU,ZE UZYWANY IDL=IPMEM(P+21) IF(IDL.NE.0)IPMEM(IDL+1)=1 C.....WYPISZ : POCZATEK MODULU 200 CALL QUADR2(184,P) RETURN END SUBROUTINE SNEXT C----------------------------------------------------------------------------- C C DOSTARCZA KOLEJNEGO SYMBOLU KODU POSREDNIEGO WYGENEROWANEGO C PRZEZ PARSER. SYMBOL TEN WPISUJE NA WB. C C CZYTA ZE STRUMIENIA "INP" , OPISANEGO W BUFORZE IBUF3 ,DO TABLICY IX . C #include "stos.h" #include "blank.h" C COMMON/TEST/TESTC,TESTS,TESTH LOGICAL TESTC,TESTS,TESTH C C INTEGER CURRENT C = INDEKS W BUFORZE IX OSTATNIO WCZYTANEGO SYMBOLU EQUIVALENCE (IX(257),CURRENT) INTEGER RECORD C = NUMER OSTATNIO WCZYTANEGO REKORDU EQUIVALENCE (IX(258),RECORD) COMMON/STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260) LOGICAL ERRFLG C.....OSTATNI W REKORDZIE? IF(CURRENT.EQ.255)GO TO 200 C NIE. CURRENT=CURRENT+1 100 WB=IX(CURRENT) C C C1000 FORMAT(' NEXT, WB =',I6) C C RETURN C.....OSTATNI. WCZYTAJ KOLEJNY REKORD 200 RECORD=IX(256) C SLOWO 256 ZAWIERA NUMER KOLEJNEGO REKORDU CALL SEEK(IBUF3,RECORD) CALL GET(IBUF3,IX) CURRENT=1 GO TO 100 END SUBROUTINE SATTACH C------------------------------------------------------ C C NA CZUBKU JEST ARGUMENT ATTACH. BADA TYP,GENERUJE KOD, C ZDEJMUJE ZE STOSU. C C ##### OUTPUT CODE : 188 . C C ##### DETECTED ERROR(S) : 477 C #include "stos.h" #include "option.h" #include "blank.h" C cdsw&ail common /stacks/ btsins, btstem C INTEGER ELEM C......... CALL SVALUE IF(STACK(VALTOP).EQ.0)RETURN IF(STACK(VALTOP-3).GT.0)GO TO 500 ELEM=STACK(VALTOP-4) ELEM=IAND(IPMEM(ELEM),15) IF(ELEM.GT.7 .AND. ELEM.LT.13 .OR. ELEM.EQ.2)GO TO 500 ELEM=STACK(VALTOP-2) C ATTACH( NONE ) ? cdsw&ail IF(STACK(VALTOP).EQ.1)ELEM=LMEM-3 if (stack(valtop).eq.1) elem = btstem-3 C = ATS NONE CALL QUADR2(188,ELEM) RETURN C NIEPOPRAWNY TYP ARGUMENTU ATTACH 500 CALL SERROR(477) RETURN END SUBROUTINE SCASE C-------------------------------------------------------------------------- C C OBSLUGUJE POCZATEK INSTRUKCJI "CASE". C CZUBEK STOSU ZAWIERA WARTOSC WYRAZENIA CASE,NASTEPNY SYMBOL C WEJSCIOWY JEST NUMEREM ETYKIETY BAZOWEJ. C WKLADA NA STOS W TABLICY LAB OPIS NOWEJ INSTRUKCJI CASE, C PRZY CZYM : JESLI ZAGNIEZDZENIE = 4 , WYSYLA OPIS POPRZEDNICH C 3 CASE-OW NA DYSK JAKO REKORD O NUMERZE IOP(2),USTAWIAJAC OVER=6, C JESLI JEDNAK ZAGNIEZDZENIE > 6 , ZWIEKSZA JEDYNIE LICZNIK NADMIAROWYCH C ZAGNIEZDZEN. C C OGRANICZENIA : ZAGNIEZDZENIE MUSI BYC < 7 , C ROZNICA MIEDZY NAJWIEKSZA A NAJMNIEJSZA ETYKIETA < 160 . C C GENERUJE : C < CASE , ATS WYRAZENIA , ETYKIETA BAZOWA -1 , OPTCSC+OPTCSF > C C C ##### OUTPUT CODE : 189 . C C ##### DETECTED ERROR(S) : 402 , 405 . C C #include "stos.h" #include "option.h" #include "blank.h" C COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260) LOGICAL ERRFLG C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM C C COMMON/CASE/DEEP,OVER INTEGER LAB(5000) EQUIVALENCE(LAB(1),IPMEM(1)) C cdsw DATA OVER/0/ #if WSIZE == 4 DATA MAXINTEGER,MININTEGER / x'7FFFFFFF' , x'80000000' / #else DATA MAXINTEGER,MININTEGER / x'7fff', -x'7fff' / #endif C C LAB ZAWIERA OPISY ZAGNIEZDZONYCH INSTRUKCJI CASE. C WYKORZYSTYWANYCH JEST 256 SLOW W TABLICY IPMEM : C OD LMEM-515 DO LMEM-260 . C POSTAC OPISU : C SLOWO 0 : TYP WYRAZENIA CASE C +1 : NUMER ETYKIETY BAZOWEJ C +2 : MINIMALNA WARTOSC ETYKIETY C +3 : MAKSYMALNA WARTOSC ETYKIETY C +4 : LICZBA ETYKIET C +5..+84 : 160 BAJTOW NA WZGLEDNY NUMER ETYKIETY C OPIS BIEZACEJ INSTRUKCJI CASE WSKAZANY JEST PRZEZ ZMIENNA DEEP C PRZYJMUJACA WARTOSCI : LMEM-600 PRZY BRAKU "CASE", C LMEM-515 PRZY ZAGNIEZDZENIU = 1 C LMEM-430 PRZY ZAGNIEZDZENIU = 2 C LMEM-345 PRZY ZAGNIEZDZENIU = 3 C LMEM-260 PRZY PRZEPELNIENIU C PRZY ZAGNIEZDZENIU 4..6 OPIS PIERWSZYCH 3 CASE-OW JEST WYSYLANY C NA DYSK JAKO REKORD O NUMERZE IOP(2), OVER PRZYJMUJE WTEDY WARTOSC 6. C PRZY ZAGNIEZDZENIACH > 6 UTRZYMYWANA JEST WARTOSC DEEP=LMEM-260 , C OPISY NOWYCH CASE-OW SA JEDYNIE ZLICZANE NA ZMIENNEJ OVER / 7,8,.../. C LAB(LMEM-260) = NRUNIV I JEST WYKORZYSTYWANE DLA UNIKNIECIA SYGNALIZACJI C NIEZGODNOSCI TYPOW ETYKIET PRZY ZBYT ZAGNIEZDZONYCH CASE-ACH. C DLA ETYKIETY O WARTOSCI N DO BAJTU O NUMERZE /NUMERACJA 0..159/ C ( N MODE 160 ) WSTAWIANA JEST ROZNICA MIEDZY ODPOWIADAJACYM C JEJ NUMEREM ETYKIETY Z PARSERA A ETYKIETA BAZOWA. C C C CALL SVALUE CALL SNEXT C TERAZ WB = NUMER ETYKIETY BAZOWEJ IF(STACK(VALTOP).EQ.0)GO TO 150 C ... ZBADAJ TYP IF(STACK(VALTOP-3).GT.0)GO TO 100 IF(STACK(VALTOP-4).EQ.NRRE)CALL SVINT(VALTOP) ELEM=STACK(VALTOP-4) C = TYP WYRAZENIA CASE /PO EWENT. KONWERSJI REAL->INTEGER / IF(ELEM.EQ.NRINT .OR. ELEM.EQ.NRCHR)GO TO 200 C NIELEGALNY TYP WYRAZENIA CASE 100 CALL SERROR(405) 150 ELEM=NRUNIV C.....DODAJ NOWY OPIS DO STOSU INSTRUKCJI CASE 200 DEEP=DEEP+85 IF(DEEP.LT.LMEM-260)GO TO 500 C PELNY STOS. BUFOR NA DYSKU JUZ UZYTY ? IF(OVER.GT.0)GO TO 1000 C JESZCZE NIE. OVER=6 DEEP=LMEM-515 CALL SEEK(IBUF3,IOP(2)) CALL PUT(IBUF3,LAB(DEEP)) C C.....WSTAW OPIS 500 LAB(DEEP)=ELEM LAB(DEEP+1)=WB LAB(DEEP+2)=MAXINTEGER LAB(DEEP+3)=MININTEGER LAB(DEEP+4)=0 C JAKO MINIMALNA I MAKSYMALNA ETYKIETA POCZATKOWO NAJWIEKSZA I NAJMNIEJSZA C LICZBA ---> POTEM KONIECZNE JEST POROWNANIE KAZDEJ ETYKIETY ZAROWNO C Z MINIMALNA JAK I MAKSYMALNA. DO 600 I=5,84 N=DEEP+I 600 LAB(N)=0 C BAJT ROWNY ZERO OZNACZA, ZE NIE WYSTAPILA ETYKIETA O WARTOSCI C WYZNACZAJACEJ TEN BAJT. C C ... JESLI STALA - WSTAW ELEM=STACK(VALTOP-2) IF(STACK(VALTOP).EQ.1)ELEM=SCONST(ELEM) C ... GENERUJ SKOK DO MIEJSCA WYBRANIA WLASCIWEJ INSTRUKCJI CALL QUADR4(189,ELEM,WB-1,OPTCSC+OPTCSF) RETURN C.....PRZEPELNIENIE : ZAGNIEZDZENIE PRZEKRACZA 6 . C NIE SYGNALIZUJ BLEDU DLA DALSZYCH ZAGNIEZDZEN 1000 IF(OVER.EQ.6)CALL MERR(402,0) OVER=OVER+1 DEEP=LMEM-260 LAB(DEEP)=NRUNIV RETURN END SUBROUTINE SCSLAB C------------------------------------------------------------------------- C C OBSLUGUJE ETYKIETE DLA INSTRUKCJI CASE. C CZUBEK STOSU POWINIEN ZAWIERAC WARTOSC ETYKIETY,NASTEPNY SYMBOL C TO NUMER ETYKIETY WYGENEROWANEJ PRZEZ PARSER. C PROCEDURA SPRAWDZA,CZY CZUBEK STOSU ZAWIERA STALA TYPU ZGODNEGO C Z TYPEM WYRAZENIA CASE I CZY WARTOSC TA JUZ NIE WYSTAPILA C LUB CZY ROZNICA MIEDZY MAKS. I MIN. ETYKIETA < 160. C WYZNACZA NOWA WARTOSC ETYKIETY MAKS. I MIN. ORAZ DO BAJTU C WYZNACZONEGO PRZEZ WARTOSC ETYKIETY WSTAWIA ROZNICE MIEDZY C NUMEREM ODPOWIADAJACEJ ETYKIETY A ETYKIETA BAZOWA. C ZWIEKSZA LICZNIK ETYKIET. C W PRZYPADKU, GDY ROZPIETOSC ETYKIET PRZEKRACZA 160,ZMIENIA C ETYKIETE BAZOWA NA -1 /DLA UNIKNIECIA DALSZEJ SYGNALIZACJI C TEGO BLEDU/. C C C ##### DETECTED ERROR(S) : 401 , 403 , 404 , 406 . C C #include "stos.h" #include "blank.h" C COMMON/CASE/DEEP,OVER INTEGER LAB(5000) EQUIVALENCE(LAB(1),IPMEM(1)) C C C TRICK FOR HAVING 2 RIGHTMOST BYTES ADDRESSABLE cdsw INTEGER BYTES cdsw BYTE BYTE(4) cdsw EQUIVALENCE ( BYTES , BYTE(1) ) C C C CALL SNEXT C WB = NUMER ETYKIETY Z PARSERA. SPRAWDZ, CZY NA STOSIE JEST STALA N=STACK(VALTOP) IF(N.EQ.0)RETURN IF(N.EQ.1)GO TO 100 C ... JAKO ETYKIETA W "CASE" WYSTAPIL OBIEKT ROZNY OD STALEJ CALL SERROR(401) RETURN C C.....ZBADAJ ZGODNOSC TYPOW /JESLI NIE BYLO PRZEPELNIENIA/ 100 IF(STACK(VALTOP-4).EQ.LAB(DEEP))GO TO 200 C NIEZGODNOSC TYPOW ETYKIETY I WYRAZENIA "CASE" IF(LAB(DEEP).NE.NRUNIV)CALL SERROR(406) RETURN C C.....USTAL NOWE WARTOSCI ETYKIET : MINIMALNA I MAKSYMALNA. C /UWAGA: ZE WZGLEDU NA INICJALIZACJE KONIECZNE OBA POROWNANIA/ 200 N=STACK(VALTOP-2) IF(N.LT.LAB(DEEP+2))LAB(DEEP+2)=N IF(N.GT.LAB(DEEP+3))LAB(DEEP+3)=N IF(LAB(DEEP+3)-LAB(DEEP+2).LT.160)GO TO 300 C ROZPIETOSC WARTOSCI ETYKIET PRZEKRACZA 160 IF(LAB(DEEP+1).EQ.-1)RETURN CALL SERROR(403) LAB(DEEP+1)=-1 RETURN C.....WYZNACZ NUMER BAJTU 300 N=MOD(N,160) IF(N.LT.0)N=N+160 L=N/2+DEEP+5 C = NUMER SLOWA W LAB m = lab(l) C = WARTOSC TEGO SLOWA WB=WB-LAB(DEEP+1) C ZWIEKSZ LICZNIK ETYKIET LAB(DEEP+4)=LAB(DEEP+4)+1 C PARZYSTY BAJT ? IF(IAND(N,1).EQ.0)GO TO 500 C ... NIEPARZYSTY, PRAWY BAJT. ETYKIETA JUZ WYSTAPILA ? if(iand(m,x'00ff').eq.0) go to 400 C ... POWTORNE WYSTAPIENIE TEJ SAMEJ ETYKIETY 350 CALL SERROR(404) RETURN C WSTAW ROZNICE : NUMER ETYKIETY - ETYKIETA BAZOWA 400 lab(l) = ior(m,wb) RETURN C ... PARZYSTY, LEWY BAJT 500 if(iand(ishft(m,-8),x'00ff').ne.0) go to 350 lab(l) = ior(ishft(wb,8),m) return END SUBROUTINE SOTHER C-------------------------------------------------------------------------- C C WOLANA PO WYSTAPIENIU "OTHERWISE" W INSTRUKCJI "CASE" . C WYPISUJE ETYKIETY /POPRZEZ SCSOUT/ I ZAZNACZA TO POPRZEZ ZMIANE C SLOWA 0 OPISU CASE NA NRUNIV. C #include "stos.h" #include "blank.h" C COMMON/CASE/DEEP,OVER INTEGER LAB(5000) EQUIVALENCE(LAB(1),IPMEM(1)) C C IF(LAB(DEEP).EQ.NRUNIV)RETURN C WYPISZ ETYKIETY I ZAZNACZ TO CALL SCSOUT LAB(DEEP)=NRUNIV RETURN END SUBROUTINE SCSOUT C---------------------------------------------------------------------------- C C C WOLANA : PRZED "OTHERWISE" /JESLI WYSTAPILO/ LUB PRZY "ESAC" . C C WYPISUJE ETYKIETY DLA "CASE". C POSTAC : "ESAC" / =190 / C LICZBA ETYKIET C NUMER ETYKIETY BAZOWEJ C WARTOSC ETYKIETY MINIMALNEJ C DLA KAZDEJ ETYKIETY SLOWO ZAWIERAJACE : C LEWY BAJT = ETYKIETA - ET.MINIMALNA C PRAWY BAJT = ODLEGLOSC OD ETYKIETY BAZOWEJ C - W KOLEJNOSCI OD ETYKIETY MINIMALNEJ DO MAKSYMALNEJ. C C NA KONCU DOPISUJE ETYKIETE DLA "OTHERWISE" /BAZOWA/ ,NIEZALEZNIE C OD TEGO,CZY "OTHERWISE" WYSTAPILO. C C C ##### OUTPUT CODE : 181 , 190 . C #include "stos.h" #include "blank.h" C COMMON/STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260) LOGICAL ERRFLG C COMMON/CASE/DEEP,OVER INTEGER LAB(5000) EQUIVALENCE(LAB(1),IPMEM(1)) C C TRICK FOR HAVING 2 RIGHTMOST BYTES ADDRESSABLE cdsw INTEGER BYTES,OBYTES cdsw BYTE BYTE(4),OBYTE(4) cdsw EQUIVALENCE ( BYTES , BYTE(1) ) , ( OBYTES , OBYTE(1) ) C INTEGER N,NR,DIFF,L,BOUND C C IF(ERRFLG)RETURN N=LAB(DEEP+2) C = ETYKIETA MINIMALNA NR=LAB(DEEP+4) C = LICZBA ETYKIET C WYPISZ "ESAC",LICZBA ETYKIET,ETYKIETA BAZOWA I MINIMALNA CALL QUADR4(190,NR,LAB(DEEP+1),N) C C.....WYPISZ DLA KAZDEJ ETYKIETY 2 BAJTY : C LEWY = ET. - ET.MIN. , PRAWY = NUMER - ETYKIETA BAZOWA C C DALEJ : C DALEJ : C DIFF = BIEZACA ETYKIETA - ET.MINIMALNA C L = NUMER SLOWA DLA KOLEJNEJ ETYKIETY C K = WARTOSC SLOWA C NR = LICZBA ETYKIET DO WYPISANIA C BOUND = NUMER PIERWSZEGO SLOWA ZA OPISEM "CASE" C BOUND=DEEP+85 N=MOD(N,160) IF(N.LT.0)N=N+160 C = NUMER BAJTU DLA ETYKIETY MINIMALNEJ , 0..159 DIFF=-1 L=DEEP+5+N/2 C = NUMER SLOWA cdsw OBYTES=0 BYTES=LAB(L) C PARZYSTA ? IF(IAND(N,1).NE.0)GO TO 300 C ... PARZYSTY,LEWY BAJT 200 DIFF=DIFF+1 C WEZ LEWY BAJT byte = iand(ishft(bytes,-8),X'00ff') if(byte.eq.0) go to 300 C WYPISZ PARE DLA TEJ ETYKIETY call quadr1(ior(byte,ishft(diff,8))) NR=NR-1 IF(NR.EQ.0)GO TO 1000 C ... NIEPARZYSTY,PRAWY BAJT 300 DIFF=DIFF+1 C WEZ PRAWY BAJT byte = iand(bytes,X'00ff') if(byte.eq.0) go to 400 C WYPISZ PARE DLA TEJ ETYKIETY call quadr1(ior(ishft(diff,8),byte)) NR=NR-1 IF(NR.EQ.0)GO TO 1000 C ... ZWIEKSZ NUMER SLOWA/ ZWAZAJAC NA GRANICE / I WCZYTAJ TO SLOWO 400 L=L+1 IF(L.EQ.BOUND)L=L-80 BYTES=LAB(L) GO TO 200 C.....WYPISZ ETYKIETE DLA "OTHERWISE" 1000 CALL QUADR2(181,LAB(DEEP+1)) RETURN END SUBROUTINE SESAC C---------------------------------------------------------------------------- C C OBSLUGUJE ZAKONCZENIE INSTRUKCJI "CASE". C OBNIZA STOS INSTRUKCJI CASE. C JESLI NIE WYSTAPILO "OTHERWISE" I NIE BYLO PRZEPELNIENIA C WYPISUJE ETYKIETY /PRZEZ SCSOUT/ C #include "stos.h" #include "blank.h" C COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260) LOGICAL ERRFLG C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM C C COMMON/CASE/DEEP,OVER INTEGER LAB(5000) EQUIVALENCE(LAB(1),IPMEM(1)) C C C.....WYPISZ ETYKIETY / O ILE NIE WYSTAPILO "OTHERWISE" LUB PRZEPELNIENIE/ IF(LAB(DEEP).NE.NRUNIV)CALL SCSOUT IF(OVER.GT.6)GO TO 500 DEEP=DEEP-85 IF(DEEP.GT.LMEM-600)RETURN C POBRAC OPIS Z DYSKU ? IF(OVER.EQ.0)RETURN CALL SEEK(IBUF3,IOP(2)) CALL GET(IBUF3,LAB(LMEM-515)) OVER=0 DEEP=LMEM-345 RETURN C.....PRZEPELNIENIE. 500 OVER=OVER-1 RETURN END SUBROUTINE SEND C------------------------------------------------------------------------- C C WOLANA PRZY END MODULU. C JESLI TRZEBA, DOPISUJE LAST-WILL. C WYPISUJE ZAKONCZENIE LAST-WILL. C C ##### OUTPUT CODE : 175 , 185 , 193 . C C #include "stos.h" #include "blank.h" C C.....BYLO LAST-WILL ? IF(LSTWILL)GO TO 1000 C NIE. ZAKONCZ INSTRUKCJE MODULU CALL SFIN C I DOPISZ LAST-WILL CALL SLWILL C C.....WYPISZ ZAKONCZENIE LAST-WILL: SKOK ZA LAST-WILL PREFIKSU C LUB BACK 1000 IF(UNIT.LE.2)GO TO 2000 IDL=IPMEM(P+21) C JESLI NIE MA PREFIKSU - BACK IF(IDL.EQ.0)GO TO 2000 C PREFIKSOWANY. CZY W CIAGU PREFIKSOWYM BYLO LAST-WILL ? C /TAK, GDY SLOWO +8 PREFIKSU <> 0 / IDL=IPMEM(IDL+8) IF(IDL.EQ.0)GO TO 2000 C SKOK ZA LAST-WILL W SEKWENCJI PREFIKSOWEJ CALL QUADR2(175,IDL) GO TO 3000 C.....BACK cdsw 2000 CALL QUADR1(193) cdsw --------------------------------------- c jesli coroutina/process to FIN (194) 2000 n = iand(ipmem(p),15) c pole = t if(n.eq.5.or.n.eq.7) go to 2100 call quadr1(193) go to 3000 c coroutina/ process 2100 call quadr1(194) cdsw ---------------------------------------- C C.....WYPISZ ZNACZNIK KONCA MODULU 3000 CALL QUADR1(185) RETURN END SUBROUTINE SFIN C------------------------------------------------------------------- C C OBSLUGUJE KONIEC INSTRUKCJI MODULU / LAST-WILL LUB END, C JESLI LAST-WILL NIE WYSTAPILO/ C KOLEJNE DWA SYMBOLE TO : NUMER ETYKIETY, NUMER LINII. C C JESLI TRZEBA,DOPISUJE INNER. C DOPISUJE ETYKIETE ORAZ NUMER LINII PRZED END. C DLA MODULOW PREFIKSOWANYCH GENERUJE SKOK ZA INNER,DLA POZOSTALYCH C END BLOKU /BACKBL/ LUB END PROCEDURY,FUNKCJI /BACKPR/ LUB C END KLASY,COROUTINY /FIN/ LUB END HANDLERA /TERMINATE/. C C ##### OUTPUT CODE : 172 , 177 , 178 , 181 , 183 , C 191 , 192 , 194 . C #include "stos.h" #include "option.h" #include "blank.h" C INTEGER AUX(6) DATA AUX/191,172,194,192,192,194/ C POWROTY Z MODULU: BACKBL,TERMINATE,FIN,BACKPR,BACKPR,FIN . C C.....DOPISAC INNER? IF(INNER.NE.0)GO TO 10 CALL QUADR2(178,IPMEM(P+23)) C ZAZNACZ BRAK INSTRUKCJI PO INNER /CHYBA,ZE Z PREFIKSU/ IPMEM(P-7)=0 IDL=IPMEM(P+21) C IDL=PREFIKS LUB 0 IF(IDL.NE.0)IPMEM(P-7)=IPMEM(IDL-7) C.....DOPISZ ETYKIETE O NUMERZE WB 10 CALL SNEXT CALL QUADR2(181,WB) C ... DOPISZ NUMER LINII CALL SNEXT IF(.NOT.OPTTRC)WB=-WB CALL QUADR2(177,WB) IF(UNIT.GT.2)GO TO 200 C ... BLOK LUB HANDLER 100 CALL QUADR1(AUX(UNIT)) RETURN C ... PREFIKSOWANY ? 200 IDL=IPMEM(P+21) IF(IDL.EQ.0)GO TO 100 C TAK. CZY SA INSTRUKCJE PO INNER ? IDL=IPMEM(IDL-7) IF(IDL.EQ.0)GO TO 100 C ... SKOK ZA INNER PREFIKSU CALL QUADR2(183,IDL) RETURN END SUBROUTINE SLWILL C---------------------------------------------------------------------- C C WYPISUJE ETYKKIETE LAST-WILL. C DLA KLASY WPISUJE DO SLOWA +8 INFORMACJE O LAST-WILL: C NUMER NAJBLIZSZEGO MODULU W CIAGU PREFIKSOWYM /Z BIEZACYM C MODULEM WLACZNIE/ MAJACEGO LAST-WILL LUB ZERO,JESLI C W CALYM CIAGU PREFIKSOWYM LAST-WILL NIE WYSTAPILO. C C ##### OUTPUT CODE : 174 . C #include "stos.h" #include "blank.h" C C.....WYPISZ ETYKIETE LAST-WILL CALL QUADR1(174) IF(UNIT.NE.6)RETURN C ... KLASA IDR=0 C JESLI JEST PREFIKS - SKOPIUJ Z PREFIKSU IDL=IPMEM(P+21) IF(IDL.NE.0)IDR=IPMEM(IDL+8) C JESLI W TYM MODULE WYSTAPILO LAST-WILL, TO WPISZ NUMER BIEZACEGO C MODULU IF(LSTWILL)IDR=P IPMEM(P+8)=IDR RETURN END SUBROUTINE SRETURN C----------------------------------------------------------------- C C DLA WYSTAPIENIA "RETURN" GENERUJE : C DLA PROCEDUR,FUNKCJI BEZ PREFIKSU BACKPR, DLA PREFIKSOWANYCH C LUB KLAS,COROUTIN BACK, DLA BLOKOW BACKBL, DLA HANDLERA BACKHD. C C C ##### OUTPUT CODE : 180 , 191 , 192 , 193 . C #include "stos.h" #include "blank.h" C INTEGER AUX(6) DATA AUX/191,180,193,192,192,193/ C POWROTY Z MODULU : BACKBL,BACKHD,BACK,BACKPR,BACKPR,BACK C C IDL=AUX(UNIT) cbc added concurrent statements call snext c check if procedure or function if (unit .ne. 4 .and. unit .ne. 5) goto 100 c generate BACKRPC call quadr1(227) 10 op = wb if (op .ne. 91 .and. op .ne. 92) goto 40 c process next ENABLE/DISABLE list 20 call snext if (wb .ne. 28) goto 10 c process next identifier call snext ind = mident(wb) elem = swhat(ind) c check if procedure or function if (elem .ne. 11 .and. elem .ne. 12) goto 30 if (op .eq. 92) ind = -ind call quadr1(ind) goto 20 30 call serror(478) goto 20 40 call quadr1(0) call snext return c Cbc JESLI MODUL PREFIKSOWANY TO BACK cbc IF(UNIT.GT.2 .AND. IPMEM(P+21).NE.0)IDL=193 100 CALL QUADR1(IDL) RETURN END SUBROUTINE SFORTO(UP,STEP) C----------------------------------------------------------------------------- C C OBSLUGUJE POCZATEK PETLI FOR. C WOLANA PO WYSTAPIENIU SYMBOLU "TO" LUB "DOWNTO". C UP = TRUE ,JESLI BYLO "TO" C STEP = TRUE ,JESLI WYSTAPILO "STEP" C STOS ZAWIERA: ZMIENNA STERUJACA,WARTOSC POCZATKOWA,KROK/JESLI BYL/, C WARTOSC KONCOWA. C NASTEPNE 2 SYMBOLE WEJSCIOWE TO NUMERY ETYKIET POCZATKU PETLI I ZA PETLA C WCZYTUJE OBA NUMERY,ZASTEPUJE 4 LUB 3 GORNE ELEMENTY STOSU PRZEZ C OPIS PETLI FOR. C JESLI KROK LUB WARTOSC KONCOWA NIE SA STALE, PRZYDZIELA IM ATRYBUTY C ROBOCZE ZYWE PO WYJSCIU Z BLOKU BAZOWEGO ORAZ GENERUJE MOVE&SAFE C DLA NICH. C C GENERUJE KOD : C WSTAWIENIE WARTOSCI POCZATKOWEJ DO R5 , C ETYKIETA POCZATKU PETLI , C PODSTAWIENIE WARTOSCI Z R5 NA ZMIENNA STERUJACA , C RELACJA I SKOK WARUNKOWY /WYJSCIE Z PETLI/ C C C C ##### OUTPUT CODE : 13 , 60 , 90 , 92 , 108 , 110 , C 139 , 152 , 181 , 208 . C C #include "stos.h" #include "blank.h" cdsw DATA SFTHEX1,SFTHEX2,SFTHEX3 /Z8000,Z4000,Z2000 / C LOGICAL UP,STEP,END1 C TRUE,JESLI: BYLO "TO", BYLO "STEP" , WARTOSC KONCOWA ROZNA OD STALEJ INTEGER END2,STEP1,STEP2 C ATS LUB WARTOSC STALEJ DLA WARTOSCI KONCOWEJ,RODZAJ KROKU C /1 JESLI STALY/, ATS LUB WARTOSC KROKU. C cdsw ------------------------------------------------ data sfthx2, sfthx3 / x'4000', x'2000' / sfthx1 = ishft(1,15) cdsw ------------------------------------------------ C C.....WARTOSC KONCOWA CALL SINDTYP END1=STACK(VALTOP).NE.1 END2=STACK(VALTOP-2) CALL SPOP C JESLI TRZEBA - ZABEZPIECZ WARTOSC KONCOWA IF(.NOT.END1)GO TO 100 C ZABEZPIECZ CALL QUADR3(208,TEMPNR+6,END2) END2=TEMPNR+6 C C.....BYLO "STEP" ? 100 IF(STEP)GO TO 200 C NIE. WSTAW KROK=1 STEP1=1 STEP2=1 GO TO 300 C TAK. 200 STEP1=STACK(VALTOP) STEP2=STACK(VALTOP-2) CALL SPOP C STALY KROK? JESLI NIE - ZABEZPIECZ IF(STEP1.EQ.1)GO TO 300 CALL QUADR3(208,TEMPNR+3,STEP2) STEP2=TEMPNR+3 C C.....WARTOSC POCZATKOWA. WPISZ DO "R5" 300 N=SVATS(VALTOP) K=STACK(VLPREV-2) C K = ATS ZMIENNEJ STERUJACEJ CALL SPOP C ZDEJMIJ TEZ ZMIENNA STERUJACA CALL SPOP LSTLSE=0 C WPISZ WARTOSC POCZATKOWA DO R5 ( REJESTR = 4 ) CALL QUADR3(139,N,4) C C C.....WSTAW OPIS PETLI NA STOS C C POSTAC OPISU : SLOWO -1 = ATS ZMIENNEJ STERUJACEJ C SLOWO -2 = WARTOSC LUB ATS KROKU C SLOWO -3 : BIT 0 = 0 --> "TO",= 1 --> "DOWNTO" C BIT 1 = 0 --> STALY KROK,= 1 --> WYLICZONY C BIT 2 = 0 --> STALA WARTOSC KONCOWA, C = 1 --> WYLICZONA C CALL SPUSH(6) LSTFOR=VALTOP STACK(VALTOP-1)=K STACK(VALTOP-2)=STEP2 N=0 C = "TO" , STALY KROK , STALA WARTOSC KONCOWA IF(.NOT.UP)N=IOR(N,SFTHX1) IF(STEP1.NE.1)N=IOR(N,SFTHX2) IF(END1)N=IOR(N,SFTHX3) STACK(VALTOP-3)=N C C C.....POCZATEK PETLI. CALL SNEXT C WB=NUMER ETYKIETY POCZATKU. GENERUJ ETYKIETE. CALL QUADR2(181,WB) CALL SNEXT C WB=NUMER ETYKIETY ZA PETLA C C ... PODSTAW WARTOSC Z R5 NA ZMIENNA STERUJACA L=TSTEMP(1) C 4 --> R5 CALL QUADR3(13,L,4) CALL QUADR3(60,K,L) C C ... GENERUJ POROWNANIE STEP1=TSTEMP(1) N=110 C ="GT INTEGER" C STALA WARTOSC KONCOWA? IF(END1)GO TO 500 C TAK N=92 C = "GT CONST" C C.....POROWNANIE I WYSKOK ZA PETLE 500 IF(.NOT.UP)N=N-2 C OPKOD "LT" = OPKOD "GT" -2 . CALL QUADR4(N,STEP1,K,END2) CALL QUADR3(152,STEP1,WB) RETURN END SUBROUTINE SFOREND C---------------------------------------------------------------------------- C C OBSLUGUJE ZAKONCZENIE PETLI FOR C ZWIEKSZA ZMIENNA STERUJACA O KROK /ZMNIEJSZA DLA "DOWNTO"/ C I WKLADA DO "R5". C ZMNIEJSZA LSTFOR,TEMPNR. C JESLI KROK LUB WARTOSC KONCOWA NIE BYLY STALE, ZWALNIA C ZAJMOWANE PRZEZ NIE ZMIENNE ROBOCZE /GENERUJE "RELEASE"/ C C GENERUJE KOD : C WSTAWIENIE DO R5 WARTOSCI ZMIENNEJ STERUJACEJ POWIEKSZONEJ C O KROK / POMNIEJSZONEJ DLA DOWNTO / , C SKOK NA POCZATEK PETLI C C C ##### OUTPUT CODE : 37 , 113 , 114 , 139 , 141 . C C #include "stos.h" #include "blank.h" C C INTEGER N,STEP,ATS,OPKOD,K C cdsw DATA SFEHEX1,SFEHEX2,SFEHEX3 /Z8000,Z4000, Z2000 / C cdsw --------------------------------------------------- data sfehx2, sfehx3 /x'4000', x'2000'/ sfehx1 = ishft(1,15) cdsw ----------------------------------------------- C.............. N=STACK(VALTOP-3) STEP=STACK(VALTOP-2) ATS=STACK(VALTOP-1) K=TSTEMP(1) C "DOWNTO" ? IF(IAND(N,SFEHX1).NE.0)GO TO 600 C....."TO" OPKOD=113 C =" + INTEGER" C STALY KROK? TAK,JESLI BIT 1 = 0 IF(IAND(N,SFEHX2).NE.0)GO TO 400 C TAK. 200 OPKOD=37 C =" + CONST" C 400 CALL QUADR4(OPKOD,K,ATS,STEP) C WSTAW DO "R5" ( REJESTR = 4 ) CALL QUADR3(139,K,4) LSTFOR=VLPREV C.....ZWOLNIJ ZMIENNE ROBOCZE,JESLI: C WARTOSC KONCOWA ROZNA OD STALEJ /BIT 2 = 1/ IF(IAND(N,SFEHX3).NE.0)CALL QUADR2(141,TEMPNR+6) C KROK ROZNY OD STALEJ /BIT 1 = 1/ IF(IAND(N,SFEHX2).NE.0)CALL QUADR2(141,TEMPNR+3) C C ZWOLNIJ NUMERY ATRYBUTOW ROBOCZYCH REZERWOWANE DLA PETLI FOR TEMPNR=TEMPNR+6 RETURN C C....."DOWNTO". STALY KROK? 600 OPKOD=114 C =" - INTEGER" IF(IAND(N,SFEHX2).NE.0)GO TO 400 C TAK STEP=-STEP GO TO 200 END SUBROUTINE SKILL C--------------------------------------------------------------- C C NA CZUBKU JEST ARGUMENT KILL. BADA TYP,GENERUJE KOD. C C C ##### OUTPUT CODE : 143 , 146 . C C ##### DETECTED ERROR(S) : 415 . C #include "stos.h" #include "blank.h" C CALL SVALUE C JESLI UNIWERSALNY-POMIN IF(STACK(VALTOP).EQ.0)RETURN C POMIN TAKZE NONE LUB TYP UNIWERSALNY IDL=STACK(VALTOP-4) IF(IDL.EQ.NRNONE .OR. IDL.EQ.NRUNIV)RETURN IDR=143 C OPKOD KILL DLA TABLICY,REKORDU C TABLICA? IF(STACK(VALTOP-3).GT.0)GO TO 50 C NIE. CZY TYP PIERWOTNY? DO 20 I=1,6 IF(IDL.EQ.CONSNR(I))GO TO 90 20 CONTINUE C..... O.K. REKORD? /POLE T=2/ IF(IAND(IPMEM(IDL),15) .NE.2)IDR=146 C OPKOD UNIWERSALNEGO KILL 50 CALL QUADR2(IDR,STACK(VALTOP-2)) RETURN 90 CALL SERROR(415) END SUBROUTINE SOPTION C------------------------------------------------------ C C OBSLUGUJE ZMIANE OPCJI C C NASTEPNY SYMBOL TO + , - NUMER OPCJI. C C NUMER I NAZWA OPCJI * ZMIENNA * WARTOSC DLA + * DLA - * ZNACZENIE DLA + C C M 2 MEMBER CONTROL * OPTMEM * 0 * 1 * WYMAGANA KONTROLA C O 3 OPTIMIZATION * OPTOPT * TRUE * FALSE * WOLNO OPTYMALIZOWAC C I 4 INDEX CONTROL * OPTIND * 0 * 2 * WYMAGANA KONTROLA C T 5 TYPE CONTROL * OPTTYP * FALSE * TRUE * WYMAGANA KONTROLA C D 6 TRACE * OPTTRC * TRUE * FALSE * WYMAGANY SLAD C C 7 CASE CONTROL * OPTCSC * 0 * 1 * WYMAGANA KONTROLA C F 8 FAST CASE * OPTCSF * 0 * 2 * SZYBKI CASE C C C OPCJA 1 - LISTING - JEST UZYWANA TYLKO PRZEZ PARSER C C C #include "stos.h" #include "option.h" #include "blank.h" C INTEGER OPTION(7),PLUS(7),MINUS(7) LOGICAL LPLUS(7),LMINUS(7) EQUIVALENCE (OPTION(1),OPTMEM) EQUIVALENCE (PLUS,LPLUS) EQUIVALENCE (MINUS,LMINUS) C PLUS,LPLUS - WARTOSCI ODPOWIEDNICH ZMIENNYCH DLA ZAPALONEJ OPCJI C MINUS,LMINUS - " " " " ZGASZONEJ OPCJI C DATA PLUS(1),PLUS(3),PLUS(6),PLUS(7)/4*0/ DATA LPLUS(2),LPLUS(4),LPLUS(5)/.TRUE.,.FALSE.,.TRUE./ DATA MINUS(1),MINUS(3),MINUS(6),MINUS(7)/1,2,1,2/ DATA LMINUS(2),LMINUS(4),LMINUS(5)/.FALSE.,.TRUE.,.FALSE./ C C C.....WCZYTAJ NUMER OPCJI CALL SNEXT C ZGASZONA ? IF(WB.GT.0)GO TO 100 C ... TAK WB=-WB-1 N=MINUS(WB) GO TO 200 C ... ZAPALONA 100 WB=WB-1 N=PLUS(WB) 200 OPTION(WB)=N RETURN END cdsw subroutine sread(*,*) SUBROUTINE SREAD(where) C----------------------------------------------------------------------- cdsw where=1 - return1, where=2 - return2 C C OBSLUGUJE OPERACJE CZYTANIA. C NA CZUBKU STOSU ZNAJDUJE SIE ARGUMENT LUB ADRES PLIKU C C WRACA DO ETYKIETY 30 LUB 40 W SDPDA C C KORZYSTA Z /BEZPARAMETROWYCH/ STANDARDOWYCH FUNKCJI C O NUMERACH : C 43,44 - READCHAR C 45,46 - READINT C 47,48 - READREAL C C C ##### OUTPUT CODE : 23 , 132 . C C ##### DETECTED ERROR(S) : 420 , 443 . C C #include "stos.h" #include "blank.h" C C C ELEM=STACK(VALTOP) IF(ELEM.EQ.0)GO TO 500 K=STACK(VALTOP-4) C PIERWSZY ARGUMENT ? IF(FLARGS.GT.0)GO TO 100 C TAK. FUNKCJA ? IF(ELEM.EQ.12)GO TO 50 C NIE. ADRES PLIKU ? IF(STACK(VALTOP-3).GT.0)GO TO 200 IF(IAND(IPMEM(K),15).NE.11)GO TO 100 C TAK. PRZEKAZ ADRES PLIKU 50 CALL SVALUE K=STACK(VALTOP-4) IF(STACK(VALTOP-3).GT.0)GO TO 200 IF(IAND(IPMEM(K),15).NE.11)GO TO 100 FLMODF=0 FILE=VALTOP CALL SFLADR FLARGS=1 C GO TO 40 cdsw RETURN2 cdsw ------------------ where=2 return cdsw ------------------ C POWROT DO PETLI W SDPDA C C C.....ARGUMENT. ZMIENNA ? 100 IF(ELEM.LT.3 .OR. ELEM.GT.5)CALL SERROR(420) C WPISZ ADRES PLIKU CALL SFLADR C ZBADAJ TYP, TABLICOWY ? IF(STACK(VALTOP-3).GT.0)GO TO 200 C N=NUMER FUNKCJI STANDARDOWEJ ,L=APETYT, K=TYP N=46 L=1 C INTEGER? IF(K.EQ.NRINT)GO TO 300 C CHAR? N=44 IF(K.EQ.NRCHR)GO TO 300 C REAL? N=48 #if WSIZE == 4 L = 1 #else L = 2 #endif IF(K.EQ.NRRE)GO TO 300 C.....ZATEM NIEPOPRAWNY TYP ZMIENNEJ W INSTRUKCJI READ 200 CALL SERROR(443) GO TO 500 C C.....OK PRZEKAZ STEROWANIE DO FUNKCJI STANDARDOWEJ 300 N=N-FLMODF CALL QUADR2(132,N) C ODCZYTAJ WARTOSC K=TSTEMP(L) CALL QUADR4(23,K,N,0) C WPISZ WARTOSC CALL SSTORE(VALTOP,K) 500 FLARGS=2 C POWROT DO ETYKIETY 30 W SDPDA C GO TO 30 cdsw RETURN1 cdsw ---------------- where=1 return cdsw ----------------- END cdsw SUBROUTINE SWRITE(*,*) subroutine swrite(where) C------------------------------------------------------------------------ cdsw where = 1 - return1, where = 2 - return2 C C OBSLUGUJE OPERACJE PISANIA. C NA STOSIE JEST ADRES PLIKU LUB WARTOSC DO WYPISANIA, A NAD NIA 0,1 LUB 2 C WARTOSCI OKRESLAJACE FORMAT. C NASTEPNY SYMBOL = LICZBA WARTOSCI OKRESLAJACYCH FORMAT /0..2/ C ZDEJMUJE TE WARTOSCI ZE STOSU. C C WRACA DO ETYKIETY 30 LUB 40 W SDPDA C C UZYWA PROCEDUR STANDARDOWYCH : C 60,61 - WRITECHAR ( ZNAK ) C 62,63 - WRITEINT ( LICZBA , SZEROKOSC POLA ) C 64,65 - WRITEREAL ( LICZBA , LICZBA ZNAKOW PRZED KROPKA , PO KROPCE ) C = WRFLT. = C 66,67 - WRITEREAL = WRFLE. = C 68,69 - WRITEREAL = WRFLF. = C 70,71 - WRITESTRING ( ADRES TEKSTU , SZEROKOSC POLA LUB -1 ) C C DOZWOLONE FORMATY : C INTEGER - 0 LUB 1 , DEFAULT = 6 C CHAR - 0 C TEXT - 0 LUB 1 , DEFAULT = -1 /=CALY TEKST/ C REAL - 0 , 1 LUB 2 , DEFAULT = 12 . 4 /=17/ C C UWAGA : PARAMETRY / W TYM WARTOSC FUNKCJI / SA NUMEROWANE OD ZERA . C C ##### OUTPUT CODE : 132 , 145 . C C ##### DETECTED ERROR(S) : 441 , 442 . C #include "stos.h" #include "blank.h" C C INTEGER FORMAT(2),I,K,N C C CALL SNEXT C WB=LICZBA WYRAZEN OKRESLAJACYCH FORMAT C.....WSTAW DO TABLICY FORMAT ATS-Y FORMATOW C I=WB 100 IF(I.EQ.0)GO TO 200 CALL SINDTYP FORMAT(I)=SVATS(VALTOP) CALL SPOP I=I-1 GO TO 100 C C.....TERAZ CZUBEK ZAWIERA WARTOSC DO WYPISANIA LUB ADRES PLIKU 200 CALL SVALUE IF(STACK(VALTOP).EQ.0)GO TO 1000 K=SVATS(VALTOP) C ZBADAJ TYP IF(STACK(VALTOP-3).NE.0)GO TO 400 I=STACK(VALTOP-4) C PIERWSZY ARGUMENT ? IF(FLARGS.GT.0)GO TO 300 C TAK. ADRES PLIKU ? IF(IAND(IPMEM(I),15).NE.11)GO TO 300 C TAK. WYSTAPIL FORMAT ? IF(WB.NE.0)CALL SERROR(441) FLMODF=0 FILE=VALTOP FLARGS=1 CALL SFLADR C GO TO 40 cdsw RETURN2 cdsw ------------------- where = 2 return cdsw -------------------- C POWROT DO PETLI W SDPDA C C.....ARGUMENT 300 CALL SFLADR IF(I.EQ.NRRE)GO TO 800 C ZATEM CHAR,INTEGER,TEXT IF(I.EQ.NRINT)GO TO 500 IF(I.EQ.NRTEXT)GO TO 600 IF(I.EQ.NRCHR)GO TO 700 C C.....ZATEM NIELEGALNY TYP ARGUMENTU INSTRUKCJI WRITE 400 I=442 410 CALL SERROR(I) GO TO 1000 C C....NIELEGALNY FORMAT 420 I=441 GO TO 410 C C C.....INTEGER. DEFAULT : 6 ZNAKOW 500 IF(WB.EQ.2)GO TO 420 IF(WB.EQ.0)FORMAT(1)=SCONST(6) N=62+FLMODF GO TO 920 C C....TEXT. -1 JESLI BRAK FORMATU 600 IF(WB.EQ.2)GO TO 420 IF(WB.EQ.0)FORMAT(1)=SCONST(-1) N=70+FLMODF GO TO 920 C C.....CHAR 700 IF(WB.NE.0)GO TO 420 N=60+FLMODF GO TO 930 C C.....REAL. DEFAULT : 12 ZNAKOW PRZED KROPKA , 4 PO KROPCE. 800 N=64+2*WB+FLMODF WB=WB+1 GO TO (810,820,830),WB C ... BEZ FORMATU , DEFAULT 12.4 , "WRFLT." = 8 810 FORMAT(1)=SCONST(12) FORMAT(2)=SCONST(4) GO TO 900 C ... FORMAT = SZEROKOSC POLA , 5 ZNAKOW PO KROPCE, "WRFLE." = 10 820 FORMAT(2)=SCONST(5) C C ... FORMAT = SZEROKOSC POLA,LICZBA ZNAKOW PO KROPCE, "WRFLF." = 11 830 CONTINUE C.....WSTAWIANIE PARAMETROW : N = NUMER PROCEDURY STANDARDOWEJ C K = ATS WARTOSCI C WSTAW PRAWY FORMAT DLA REAL 900 CALL QUADR4(145,FORMAT(2),N,2) C WSTAW /LEWY/ FORMAT 920 CALL QUADR4(145,FORMAT(1),N,1) C WSTAW WARTOSC 930 CALL QUADR4(145,K,N,0) C PRZEKAZ STEROWANIE CALL QUADR2(132,N) 1000 FLARGS=2 C POWROT DO ETYKIETY 30 W SDPDA cdsw RETURN1 cdsw ----------------- where=1 return cdsw ----------------- END SUBROUTINE SFTEST C--------------------------------------------------------- C C SPRAWDZA, CZY ELEMENT Z CZUBKA STOSU (UNIW.,STALA, C WARTOSC,ZMIENNA,TABL.STAT.,ELEM.TABL.) JEST TYPU FILE . C 'NONE' NIE JEST AKCEPTOWANE C C ##### DETECTED ERROR(S) : 413 . C #include "stos.h" #include "blank.h" C N=STACK(VALTOP-4) IF(STACK(VALTOP-3).GT.0 .OR. (N.NE.NRUNIV.AND. X IAND(IPMEM(N),15).NE.11))CALL SERROR(413) RETURN END SUBROUTINE SFLADR C--------------------------------------------------------- C C ZAPEWNIA, ZE (R6-12) ZAWIERA ADRES PLIKU C - DLA OPERACJI NA PLIKU WSKAZYWANYM C C ##### OUTPUT CODE : 139 . C #include "stos.h" #include "blank.h" C IF(FILE.EQ.0 .OR. FLREADY)RETURN CALL QUADR3(139,STACK(FILE-2),-45) C -45 --> (R6-12) FLREADY=.TRUE. RETURN END cdsw SUBROUTINE SPUT(*,*) subroutine sput(where) C--------------------------------------------------------- cdsw where = 1 - return1, where = 2 - return2 C C OBSLUGUJE 'PUT' . C CZUBEK STOSU ZAWIERA ADRES PLIKU LUB ARGUMENT. C C WRACA BEZPOSREDNIO DO ETYKIETY 30 LUB 40 W SDPDA. C C ##### OUTPUT CODE : 132 , 145 . C C ##### DETECTED ERROR(S) : 445 . C #include "stos.h" #include "blank.h" C CALL SVALUE C ADRES PLIKU JUZ WYSTAPIL ? IF(FLARGS.GT.0)GO TO 100 C JESZCZE NIE CALL SFTEST FILE=VALTOP FLARGS=1 FLMODF=0 CALL SFLADR C GO TO 40 cdsw RETURN2 cdsw ------------------ where = 2 return cdsw ------------------ C POWROT DO SDPDA C C.....ARGUMENT 100 FLARGS=2 CALL SFLADR N=STACK(VALTOP-4) C SEMAPHORE ? if(iand(ipmem(n),15).eq.9) go to 799 if(stack(valtop-3).gt.0) go to 799 IF(N.EQ.NRINT)GO TO 400 IF(N.EQ.NRCHR)GO TO 300 IF(N.EQ.NRRE )GO TO 500 if(n.eq.nrtext) go to 799 C ZATEM REFERENCJA lub nielegealny typ go to 799 CPS 600 N=56 dziwne, ta etykieta nie jest uzywana ! CPS GO TO 1000 300 N=53 GO TO 1000 400 N=54 GO TO 1000 500 N=55 GO TO 1000 C 1000 CALL QUADR4(145,SVATS(VALTOP),N,0) CALL QUADR2(132,N) C GO TO 30 cdsw RETURN1 cdsw ------------------ where = 1 return cdsw ------------------ C POWROT DO SDPDA 799 call serror(445) where = 1 return END cdsw SUBROUTINE SGET(*,*) subroutine sget(where) C--------------------------------------------------------- cdsw where = 1 - return1 , where = 2 - return2 C C OBSLUGUJE 'GET' C CZUBEK STOSU ZAWIERA ARGUMENT LUB ADRES PLIKU. C C WRACA DO ETYKIETY 30 LUB 40 W SDPDA. C C ##### OUTPUT CODE : 23 , 132 , 145 . C C ##### DETECTED ERROR(S) : 420 , 446 . C #include "stos.h" #include "blank.h" C INTEGER ELEM,N,ATS C C ADRES PLIKU JUZ WYSTAPIL ? IF(FLARGS.GT.0)GO TO 100 C JESZCZE NIE CALL SVALUE CALL SFTEST FILE=VALTOP FLARGS=1 FLMODF=0 CALL SFLADR C GO TO 40 cdsw RETURN2 cdsw ------------------------ where = 2 return cdsw ------------------------ C POWROT DO SDPDA C C.....ARGUMENT. ZMIENNA ? 100 FLARGS=2 CALL SFLADR ELEM=STACK(VALTOP) N=STACK(VALTOP-4) C SEMAPHORE ? IF(IAND(IPMEM(N),15).EQ.9)GO TO 9000 if(stack(valtop-3).gt.0) go to 9000 IF(N.EQ.NRINT)GO TO 1000 IF(N.EQ.NRCHR)GO TO 1200 IF(N.EQ.NRRE )GO TO 1100 IF(N.EQ.NRTEXT)GO TO 9000 C ZATEM REFERENCJA.lub nielegalny typ go to 9000 C POWROT DO PETLI W SDPDA C C ... INTEGER 1000 N=50 GO TO 1500 C ... REAL 1100 N=51 #if WSIZE == 4 ats = tstemp(1) #else ats = tstemp(2) #endif GO TO 2000 C ... CHAR 1200 N=49 C C 1500 ATS=TSTEMP(1) C ZMIENNA ? 2000 IF(ELEM.LT.3 .OR. ELEM.GT.5)CALL SERROR(420) CALL QUADR2(132,N) CALL QUADR4(23,ATS,N,0) CALL SSTORE(VALTOP,ATS) C GO TO 30 cdsw RETURN1 cdsw ---------------- where = 1 return cdsw ---------------- C POWROT DO SDPDA C.....NIELEGALNY TYP ARGUMENTU 9000 CALL SERROR(446) C GO TO 30 cdsw RETURN1 cdsw ---------------- where = 1 return cdsw ----------------- end SUBROUTINE SEOF(N) C-------------------------------------------------------------- cdsw procedura zostala podzielona na dwie - seof i seof0 C C OBSLUGUJE OPERATORY 'EOF' I 'EOLN'. C WSTAWIA NA STOS ODCZYTANA WARTOSC FUNKCJI. C C WEJSCIE SEOF0 ODPOWIADA BEZPARAMETROWYM EOF, EOLN. C WEJSCIE SEOF ODPOWIADA EOF, EOLN Z PODANYM (NA CZUBKU STOSU) C ADRESEM PLIKU (JEST USUWANY). C N = NUMER ODPOWIEDNIEJ FUNKCJI STANDARDOWEJ C (39, 40 DLA EOF, 74, 75 DLA EOLN) C C C ###### GENEROWANY KOD : 23 , 132 , 139 . C C #include "stos.h" #include "blank.h" C C C......CZUBEK STOSU ZAWIERA ADRES PLIKU CALL SVALUE CALL SFTEST C PRZEKAZ ADRES PLIKU DO (R6-12) CALL QUADR3(139,STACK(VALTOP-2),-45) CALL SPOP C DALEJ JAK DLA BEZPARAMETROWYCH EOF, EOLN C call seof0(n) return end SUBROUTINE SEOF0(N) C-------------------------------------------------------------- cdsw procedura zostala podzielona na dwie - seof i seof0 C C OBSLUGUJE OPERATORY 'EOF' I 'EOLN'. C WSTAWIA NA STOS ODCZYTANA WARTOSC FUNKCJI. C C WEJSCIE SEOF0 ODPOWIADA BEZPARAMETROWYM EOF, EOLN. C WEJSCIE SEOF ODPOWIADA EOF, EOLN Z PODANYM (NA CZUBKU STOSU) C ADRESEM PLIKU (JEST USUWANY). C N = NUMER ODPOWIEDNIEJ FUNKCJI STANDARDOWEJ C (39, 40 DLA EOF, 74, 75 DLA EOLN) C C C ###### GENEROWANY KOD : 23 , 132 , 139 . C C #include "stos.h" #include "blank.h" C C INTEGER ATS C...................BEZPARAMETROWE EOF , EOLN C C WYWOLAJ FUNKCJE CALL QUADR2(132,N) ATS=TSTEMP(1) C PODCZYTAJ WARTOSC ( PARAMETR 0 ) CALL QUADR4(23,ATS,N,0) C WSTAW NA STOS ODCZYTANA WARTOSC CALL SPUSH(2) STACK(VALTOP-1)=0 STACK(VALTOP-2)=ATS STACK(VALTOP-3)=0 STACK(VALTOP-4)=NRBOOL STACK(VALTOP-5)=0 RETURN END INTEGER FUNCTION SVATS(ELEM) C-------------------------------------------------------------- C C ZWRACA ATS WARTOSCI Z MIEJSCA ELEM STOSU . C (UNIWERSALNY,STALA,WARTOSC) C DLA STALEJ GENERUJE NOWY ATS. C #include "stos.h" #include "blank.h" cdsw&ail common /stacks/ btsins, btstem C SVATS=STACK(ELEM-2) IF(STACK(ELEM).NE.1)RETURN C STALA N=STACK(ELEM-4) IF(N.EQ.NRRE)GO TO 100 IF(N.EQ.NRNONE)GO TO 200 C ZATEM : INTEGER,CHAR,BOOLEAN,TEXT SVATS=SCONST(SVATS) RETURN C ... STALA REAL 100 SVATS=SCREAL(SVATS) RETURN C ... STALA NONE cdsw&ail 200 SVATS=LMEM-3 200 svats = btstem - 3 RETURN END C SUBROUTINE SAVEVAR(ELEM) C------------------------------------------------------- C C ZABEZPIECZA ADRES ZMIENNEJ (UOGOLNIONEJ) Z MIEJSCA C ELEM STOSU. C #include "stos.h" #include "blank.h" C C N=STACK(ELEM)-2 GO TO (300,400,500),N C.....ZMIENNA C ADRES PRZED KROPKA : 300 CALL SAFE(STACK(ELEM-7)) RETURN C.....ELEMENT TABLICY C ADRES TABLICY : 400 CALL SAFE(STACK(ELEM-2)) C I INDEKS, JESLI ROZNY OD STALEJ : IF(STACK(ELEM-2).GT.0)GO TO 300 cdsw added - bug! return C.....TABLICA STATYCZNA 500 GO TO 300 END SUBROUTINE SCHECK(ERROR,TYP) C-------------------------------------------------------- C C POMOCNICZA. JESLI CZUBEK STOSU NIE JEST TYPU PROSTEGO C TYP LUB UNIWERSALNEGO - SYGNALIZUJE BLAD ERROR. C #include "stos.h" #include "blank.h" C C INTEGER ERROR,TYP I=STACK(VALTOP-4) IF(STACK(VALTOP-3).NE.0 .OR. (I.NE.NRUNIV .AND. I.NE.TYP)) X CALL SERROR(ERROR) RETURN END SUBROUTINE SNOT C----------------------------------------------------------------- C C OBSLUGUJE OPERATOR NOT. ARGUMENT JEST NA CZUBKU . C C C ##### OUTPUT CODE : 42 . C C ##### DETECTED ERROR(S) : 417 . C #include "stos.h" #include "blank.h" C C CALL SNEXT CALL SVALUE C JESLI UNIWERSALNY-POMIN IF(STACK(VALTOP).EQ.0)RETURN C SPRAWDZ TYP CALL SCHECK(417,NRBOOL) C..... CZY STALA? IF(STACK(VALTOP).EQ.1)GO TO 51 C NIE. CZY WB= IF.FALSE LUB IF.TRUE ? IF(WB.EQ.29 .OR. WB.EQ.30)GO TO 60 C.....NIE, WYKONAJ NOT. IDL=TSTEMP(1) CALL QUADR3(42,IDL,STACK(VALTOP-2)) STACK(VALTOP)=2 STACK(VALTOP-2)=IDL RETURN C.....STALA, ZMIEN WARTOSC. 51 STACK(VALTOP-2)=-1-STACK(VALTOP-2) RETURN C.....NOT PRZED SKOKIEM WARUNKOWYM,ZMIEN RODZAJ SKOKU 60 WB=59-WB RETURN END SUBROUTINE SARITH C-------------------------------------------------------------------------- C C 1982.09.15 C C OBSLUGUJE 1 LUB 2 - ARGUMENTOWE OPERACJE ARYTMETYCZNE. C WB=NUMER OPERACJI, 1..8 OZNACZaJA: C ABS,MINUS UNARNY,+,-,*,/,DIV,MODE C ARGUMENT LUB 2 ARGUMENTY SA NA CZUBKU STOSU. C ARGUMENTY ZASTEPUJE PRZEZ WYNIK OPERACJI /UNIWERSALNY,STALA,WARTOSC/ C C WYROZNIA PRZYPADKI: C OBA ARGUMENTY STALE, C DODAWANIE,ODEJMOWANIE STALEJ C MNOZENIE PRZEZ STALE 0..10, C DZIELENIE PRZEZ 0,1,2,4,8. C C C ##### OUTPUT CODE : 37 , 48 , 49 , 50 , 51 , 64 , 65 , 66 , C 67 , 68 , 69 , 70 , 71 , 72 , 73 , 74 , C 75 , 113 , 114 , 115 , 117 , 118 , 119 , C 120 , 121 , 122 , 140 . C C ##### DETECTED ERROR(S) : 460 . C #include "stos.h" #include "option.h" #include "blank.h" cdsw&bc real y integer*2 m(2) equivalence (y, m(1)) CCCCCCCCCCCCCCC C ROBOCZE INTEGER ELEM,OPKOD C REAL XREAL,YREAL C C INTEGER CREAL C C C........................ C C TERAZ WB=NUMER OPERACJI C WYLICZ WARTOSC CALL SVALUE C I WSTAW TYP PRAWEGO ARGUMENTU TRDIM=STACK(VALTOP-3) TRBAS=STACK(VALTOP-4) IDR=STACK(VALTOP-1) C.....PRZESKOCZ,JESLI OPERACJA 2-ARGUMENTOWA IF(WB.GT.2)GO TO 1000 C.....ABS LUB MINUS UNARNY IF(STACK(VALTOP).EQ.0)RETURN C ZBADAJ TYP TLDIM=TRDIM TLBAS=TRBAS IDL=IDR CALL MARITH(1) C CZY STALA? IF(STACK(VALTOP).EQ.1)GO TO 200 C NIE. INTEGER? IF(STACK(VALTOP-4).EQ.NRINT)GO TO 150 C ZATEM ZMIENNA,WARTOSC TYPU REAL #if WSIZE == 4 result = tstemp(1) #else result = tstemp(2) #endif 100 CALL QUADR3(49+WB,RESULT,STACK(VALTOP-2)) C ZASTAP PRZEZ "WARTOSC" Z NOWYM RESULT STACK(VALTOP)=2 STACK(VALTOP-2)=RESULT RETURN C ZMIENNA,WARTOSC TYPU INTEGER 150 RESULT=TSTEMP(1) WB=WB-2 GO TO 100 C STALA JAKO ARGUMENT ABS LUB MINUSA UNARNEGO 200 IF(STACK(VALTOP-4).EQ.NRRE)GO TO 250 IF((WB.EQ.1 .AND. STACK(VALTOP-2).LT.0).OR.(WB.EQ.2)) X STACK(VALTOP-2)= -STACK(VALTOP-2) RETURN C STALA REAL 250 RESULT=STACK(VALTOP-2) cdsw&bc XREAL=STALER(RESULT) #if WSIZE == 4 xreal=staler(result) #else n1 = result*2-1 m(1) = ipmem(n1) m(2) = ipmem(n1+1) xreal = y #endif c IF((WB.EQ.1 .AND. XREAL.LT.0.0).OR.(WB.EQ.2)) X STACK(VALTOP-2)=CREAL(-XREAL) RETURN C C................ OPERACJE 2-ARGUMENTOWE....................... C C ROZROZNIA PRZYPADKI : OBA ARGUMENTY STALE , JEDEN ARGUMENT STALY, C MNOZENIE LUB DZIELENIE PRZEZ WYROZNIONE STALE C /0,1,2,3,4,5,6,7,8,9,10 LUB 0,1,2,4,8/ C 1000 CALL SVALU2 ELEM=0 C JESLI JEDEN Z ARGUMENTOW UNIWERSALNY-ZASTAP OBA PRZEZ UNIWERSALNY IF(STACK(VALTOP)*STACK(VLPREV).EQ.0)GO TO 1400 C WSTAW TYP I NAZWE LEWEGO ,SPRAWDZ TYPY TLDIM=STACK(VLPREV-3) TLBAS=STACK(VLPREV-4) IDL=STACK(VLPREV-1) ELEM=2 C ELEM="WARTOSC",UZYWANE PO SKOKU DO 1400. OPKOD=1 IF(WB.GT.6)OPKOD=2 IF(WB.EQ.6)OPKOD=3 CALL MARITH(OPKOD) C WYKONAJ EWENTUALNA KONWERSJE IF(CONVR.EQ.1)CALL SVREAL(VALTOP) IF(CONVL.EQ.1)CALL SVREAL(VLPREV) IDL=STACK(VLPREV-2) IDR=STACK(VALTOP-2) C IDL,IDR = WARTOSC LUB NUMER STALEJ LUB ATS LEWEGO,PRAWEGO ARGUMENTU. C DLA JEDNEGO ARG.STALEGO - IDR=STALA C C C..........STALE ARGUMENTY? CALL SARGMT GO TO (2000,4000,1600,1050),ARG C C..........OBA ROZNE OD STALYCH C 1050 IF(TRESLT.EQ.NRRE)GO TO 1500 C C C INTEGER 1100 RESULT=TSTEMP(1) 1200 OPKOD=113-3 C GENERUJ OPERACJE 1300 CALL QUADR4(OPKOD+WB,RESULT,IDL,IDR) C C C.....ZASTAP OBA PRZEZ "WARTOSC" TYPU TRESLT C 1400 CALL SRESULT(ELEM) RETURN C C C REAL 1500 OPKOD=119-3 #if WSIZE == 4 result = tstemp(1) #else result = tstemp(2) #endif GO TO 1300 C C.....PRAWY ARGUMENT STALY,LEWY NIE /DLA + , * ROWNIEZ ODWROTNIE/ C JESLI REAL - WSTAW STALA I DALEJ JAK DLA OBU ROZNYCH OD STALYCH 1600 IF(TRESLT.NE.NRRE)GO TO 4100 C C TUTAJ ROZSZERZENIE O ARGUMENT 0.0 LUB 1.0 C IDR=SCREAL(IDR) GO TO 1500 C C C.............OBA ARGUMENTY STALE. OBLICZ WYNIK. C 2000 ELEM=1 WB=WB-2 IF(TRESLT.NE.NRINT)GO TO 3000 C C.....OPERACJA NA 2 STALYCH INTEGER GO TO(2100,2200,2300,2400,2400,2500),WB C + 2100 RESULT=IDL+IDR GO TO 1400 C - 2200 RESULT=IDL-IDR GO TO 1400 C * 2300 RESULT=IDL*IDR GO TO 1400 C / , DIV 2400 IF(IDR.EQ.0)GO TO 4800 RESULT=IDL/IDR GO TO 1400 C MODE 2500 RESULT=MOD(IDL,IDR) GO TO 1400 C C.....OPERACJA NA 2 STALYCH TYPU REAL 3000 continue cdsw&bc XREAL=STALER(IDR) cdsw&bc YREAL=STALER(IDL) #if WSIZE == 4 xreal=staler(idr) yreal=staler(idl) #else n1 = idr*2-1 m(1) = ipmem(n1) m(2) = ipmem(n1+1) xreal = y n1 = idl*2-1 m(1) = ipmem(n1) m(2) = ipmem(n1+1) yreal = y #endif C XREAL,YREAL = WARTOSC PRAWEGO,LEWEGO ARGUMENTU GO TO (3100,3200,3300,3400),WB C + 3100 XREAL=YREAL+XREAL GO TO 3500 C - 3200 XREAL=YREAL-XREAL GO TO 3500 C * 3300 XREAL=YREAL*XREAL GO TO 3500 C / cailvax and all other computers: 3400 IF(YREAL.EQ. 0.0)GO TO 4800 3400 if(xreal .eq. 0.0)go to 4800 XREAL=YREAL/XREAL C WSTAW XREAL DO SLOWNIKA STALYCH REAL 3500 RESULT=CREAL(XREAL) GO TO 1400 C C.....LEWY ARGUMENT STALY,PRAWY NIE. C C OPERACJA SYMETRYCZNA? 4000 IF(WB.EQ.3 .OR. WB.EQ.5)GO TO 4050 C OPERACJA NIESYMETRYCZNA IF(TRESLT.EQ.NRRE)GO TO 4030 IDL=SCONST(IDL) GO TO 1100 4030 IDL=SCREAL(IDL) C C TUTAJ ROZSZERZENIE O LEWY ARGUMENT 0.0 DLA - , / . C GO TO 1500 C C OPERACJA SYMETRYCZNA: + , * .ZAMIEN IDL,IDR 4050 TRDIM=IDL IDL=IDR IDR=TRDIM GO TO 1600 C C.....WSPOLNA AKCJA. PRAWY ARG.STALY LUB OP.SYM. I LEWY STALY C IDL = ATS ROZNEGO OD STALEJ ARG.,IDR=STALA C OBA ARGUMENTY TYPU INTEGER. C 4100 RESULT=TSTEMP(1) GO TO (4150,4150,4300,4200,4400,4700,4700,4720),WB 4150 CONTINUE C C........... C - . ZMIEN ZNAK STALEJ 4200 IDR= -IDR C C........... C + , - . +0 ? 4300 IF(IDR.EQ.0)GO TO 4810 CALL QUADR4(37,RESULT,IDL,IDR) GO TO 1400 C C.......... C * . JAKA TO STALA? 4400 IF(IDR.LT.0 .OR. IDR.GT.10)GO TO 4720 C ZATEM STALA 0..10 IF(IDR-1) 4805 , 4810 , 4500 C ... MNOZENIE PRZEZ STALA 2..10 /REALIZOWANE PRZEZ SHIFT/ 4500 OPKOD=62+IDR 4600 CALL QUADR3(OPKOD,RESULT,IDL) GO TO 1400 C C........... C DIVE 4700 IF(IDR.GE.0 .AND. IDR.LE.8)GO TO 4750 C WSTAW STALA 4720 IDR=SCONST(IDR) GO TO 1200 C ... DZIELENIE PRZEZ STALE 0..8 . WYROZNIJ 0,1,2,4,8 4750 N=IDR+1 GO TO (4800,4810,4820,4720,4840,4720,4720,4720,4880),N C C.....DZIELENIE PRZEZ ZERO 4800 CALL SERROR(460) C ZASTAP PRZEZ STALA ZERO / DLA MNOZENIA LUB DZIELENIA PRZEZ ZERO / 4805 ELEM=1 IF(.NOT.OPTOPT)CALL QUADR2(140,IDL) RESULT=IDR GO TO 1400 C ... ZASTAP PRZEZ ARGUMENT ROZNY OD STALEJ / MNOZENIE,DZIELENIE C PRZEZ 1 LUB DODAWANIE,ODEJMOWANIE 0 / 4810 RESULT=IDL GO TO 1400 C C ... DIVE 2 4820 OPKOD=75 GO TO 4600 C ... DIVE 4 4840 OPKOD=74 GO TO 4600 C ... DIVE 8 4880 OPKOD=73 GO TO 4600 C END SUBROUTINE SRELAT C----------------------------------------------------------------------------- C C DWA GORNE ELEMENTY STOSU ZAWIERAJA ARGUMENTY RELACJI : C IS , IN DLA WB= 1,2 LUB C = , <> , < , <= , > , >= . WB=NUMER RELACJI /3..8/ C GENERUJE KOD WYZNACZAJACY WARTOSC RELACJI. C WYROZNIA PRZYPADKI : OBA ARGUMENTY STALE, C POROWNANIE ZE STALA INTEGER C POROWNANIE Z ZEREM / 0 LUB 0.0 / C POROWNANIE Z NONE . C C C ##### OUTPUT CODE : 55 , 56 , 76 , 77 , 78 , 79 , 80 , 81 , C 82 , 83 , 88 , 89 , 90 , 91 , 92 , 93 , C 106 , 107 , 108 , 109 , 110 , 111 , C 123 , 124 , C 125 , 126 , 127 , 128 , 129 , 130 . C C ##### DETECTED ERROR(S) : 475 , 476 . C C #include "stos.h" #include "blank.h" C CCCCCCCCCCCCCCCCCCCCCCCC INTEGER REL(6),RELCONV(6),RLCASE,ELEM C REL - TABLICA WYZNACZAJACA WYNIKI POROWNANIA DLA 6 RELACJI, C BITY 15,14,13 =0 JESLI DLA L

P WYNIK JEST FALSE C RELCONV - TABLICA ZAMIANY POROWNAN PRZY ZAMIANIE ARGUMENTOW C RLCASE - TYP POROWNANIA: 1,3,4-INTEGER,2-REAL,5,6-REFERENCYJNY C ELEM - RODZAJ ELEMENTU REAL X cdsw&bc real y, yy integer*2 m(2) equivalence (y, m(1)) c common/stream/ errflg,line,ibuf2(265),ibuf3(7),junk(260) C DATA RELCONV/3,4,7,8,5,6/,REL/2,5,1,3,4,6/ C.......... ELEM=0 CALL SVALU2 C WSTAW TYP I NAZWE LEWEGO ARGUMENTU TLDIM=STACK(VLPREV-3) TLBAS=STACK(VLPREV-4) IDL=STACK(VLPREV-1) C IS,IN ? IF(WB.LT.3)GO TO 7000 CALL SVALUE IF(STACK(VALTOP)*STACK(VLPREV).EQ.0)GO TO 3200 C WSTAW TYPY ARGUMENTOW TRDIM=STACK(VALTOP-3) TRBAS=STACK(VALTOP-4) IDR=STACK(VALTOP-1) ELEM=2 C JAKA RELACJA? IF(WB.LE.4)GO TO 200 C < , <= , > , >= CALL MARITH(1) RLCASE=1 IF(TRESLT.EQ.NRRE)RLCASE=2 GO TO 300 C = , <> C WSTAW INFORMACJE O DOSTEPNOSCI TYPOW FORMALNYCH 200 OBJL=STACK(VLPREV-6) OBJR=STACK(VALTOP-6) CALL MEQUAL(RLCASE) C C RLCASE OKRESLA TYP POROWNANIA: 1,3,4-INTEGER,2-REAL,5,6-REFERENCYJNE 300 IF(CONVL.EQ.1)CALL SVREAL(VLPREV) IF(CONVR.EQ.1)CALL SVREAL(VALTOP) IDL=STACK(VLPREV-2) IDR=STACK(VALTOP-2) C IDL,IDR=WARTOSC LUB NUMER STALEJ LUB ATS LEWEGO,PRAWEGO ARGUMENTU CALL SARGMT C WYBIERZ TYP POROWNANIA: INTEGER,REAL,REFERENCYJNY GO TO (1000,3000,1000,1000,5000,5000),RLCASE C C..........INTEGER C C C STALE ARGUMENTY? 1000 GO TO (1050,1200,1500,1300),ARG C.....OBA STALE,WYZNACZ WARTOSC RELACJI 1050 X=FLOAT(IDL-IDR) GO TO 3100 C.....LEWY STALY,PRAWY NIE. ZAMIEN. 1200 OBJL=IDL IDL=IDR IDR=OBJL WB=RELCONV(WB-2) GO TO 1500 C.....LEWY ROZNY OD STALEJ. C POROWNANIE 1300 RLCASE=103 C ="POROWNANIE INTEGER"-3 GO TO 1800 C.....PRAWY STALY,LEWY NIE. 1500 RLCASE=85 C ="POROWNANIE ZE STALA"-3 C CZY Z ZEREM? IF(IDR.EQ.0)GO TO 3400 C NIE C C.....GENERUJ POROWNANIE 2-ARG. 1800 RESULT=TSTEMP(1) CALL QUADR4(RLCASE+WB,RESULT,IDL,IDR) GO TO 3200 C C C..........POROWNANIE 2 ARGUMENTOW REAL C 3000 RLCASE=122 C ="POROWNANIE REAL"-3 cdsw GO TO (3050,3300,4000,1800),ARG cdsw -------------------------- go to (3050,3700,4000,1800),arg cdsw -------------------------- C.....OBA STALE. WYZNACZ WARTOSC RELACJI cdsw&bc 3050 X=STALER(IDL)-STALER(IDR) #if WSIZE == 4 3050 x=staler(idl)-staler(idr) #else 3050 n1 = idl*2-1 m(1) = ipmem(n1) m(2) = ipmem(n1+1) yy = y n1 = idr*2-1 m(1) = ipmem(n1) m(2) = ipmem(n1+1) x = yy-y #endif c 3100 IF ( X ) 3110,3120,3130 C LEWY < PRAWY 3110 RESULT=IAND(REL(WB-2),1) GO TO 3150 C LEWY = PRAWY 3120 RESULT=IAND(REL(WB-2),2) GO TO 3150 C LEWY > PRAWY 3130 RESULT=IAND(REL(WB-2),4) 3150 IF(RESULT.NE.0)RESULT=-1 C RESULT ZAWIERA REPREZENTACJE TRUE LUB FALSE ELEM=1 C C C.....ZASTAP OBA ARGUMENTY PRZEZ WYNIK TYPU BOOLEAN C C 3200 TRESLT=NRBOOL CALL SRESULT(ELEM) RETURN C C C.....LEWY STALY,PRAWY NIE. LEWY = 0.0 ? cdsw3300 IF(STALER(IDL).NE. 0.0)GO TO 3700 C LEWY=0.0, ZAMIEN POROWNANIA cdsw WB=RELCONV(WB-2) cdsw IDL=IDR C.....GENERUJ POROWNANIE 1-ARG. 3400 RESULT=TSTEMP(1) CALL QUADR3(73+WB,RESULT,IDL) C ZASTAP PRZEZ WARTOSC GO TO 3200 C.....LEWY ARG. STALY<>0.0 ,WSTAW STALA 3700 IDL=SCREAL(IDL) GO TO 1800 C.....PRAWY STALY,LEWY NIE. PRAWY = 0.0 ? cdsw 4000 IF(STALER(IDR).EQ. 0.0)GO TO 3400 C NIE 0.0 , WSTAW STALA cdsw ---------- added ------- 4000 continue cdsw ------------------------ IDR=SCREAL(IDR) GO TO 1800 C C C C C..........REFERENCYJNE. 5000 GO TO (5050,5200,5300,5600),ARG C OBA NONE ,WSTAW TRUE DLA = , FALSE DLA <> / -1 LUB 0 / 5050 ELEM=1 RESULT=WB-4 GO TO 3200 C.....LEWY NONE,PRAWY NIE. ZAMIEN 5200 IDL=IDR C.....PRAWY NONE,LEWY NIE 5300 WB=WB+6 GO TO 3400 C.....OBA ROZNE OD NONE. ### BEZ DYNAMICZNEJ KONTROLI TYPOW ##### 5600 RLCASE=120 C ="EQ REF"-3 GO TO 1800 C C.....RELACJA IS , IN C C ZBADAJ TYP LEWEGO 7000 IF(STACK(VLPREV).EQ.0)GO TO 7100 TLBAS=IAND(IPMEM(TLBAS),15) IF((TLBAS.GT.7 .AND. TLBAS.LT.13).OR.TLDIM.GT.0)CALL MERR(475,IDL) C ZBADAJ PRAWY : REKORD,KLASA? 7100 IDL=STACK(VALTOP) IF(IDL.EQ.0)GO TO 3200 IF(IDL.EQ.8.OR.IDL.EQ.9)GO TO 7200 CALL SERROR(476) GO TO 3200 C O.K. LEWY=NONE ? 7200 IF(STACK(VLPREV).EQ.1)GO TO 7300 ELEM=2 RESULT=TSTEMP(1) CALL QUADR4(54+WB,RESULT,STACK(VLPREV-2),STACK(VALTOP-4)) GO TO 3200 C LEWY=NONE : NONE IS -> FALSE , NONE IN -> TRUE 7300 ELEM=1 RESULT=1-WB GO TO 3200 END SUBROUTINE SNEWARR C----------------------------------------------------------------------------- C C OBSLUGUJE GENERACJE TABLICY. C GORNE 3 ELEMENTY STOSU TO: ZMIENNA TABLICOWA,DOLNA GRANICA /UNIWERSALNY, C STALA,WARTOSC/,GORNA GRANICA /NA CZUBKU/. C ZDEJMUJE ZE STOSU 2 GORNE /1 ZOSTAWIA/,NIE WOLA SNEXT C C C ##### OUTPUT CODE : 23 , 132 ,145 . C C ##### DETECTED ERROR(S) : 433 , 435 . C #include "stos.h" #include "blank.h" C C INTEGER AUX(4) C RUNNING-SYSTEM IDENTIFIERS OF ARRAY ELEMENTS : INTEGER,REAL,--,REFERENCE C INTEGER I,N DATA AUX / -1 , -3 , 0 , -2 / C C..... CALL SINDTYP C STALE GRANICE? IF(STACK(VALTOP).NE.1 .OR. STACK(VLPREV).NE.1)GO TO 60 C TAK. DOLNA < GORNA ? IF(STACK(VLPREV-2).GT.STACK(VALTOP-2)) X CALL SERRO2(433,VLPREV-9) C NAZWA 3-GO OD GORY,2-GI MA APETYT 8 /STALA/ 60 CONTINUE C WSTAW GRANICE GORNA,DOLNA DO 100 I=1,2 CALL QUADR4(145,SVATS(VALTOP),1,I-1) C WSTAW WARTOSC I-TEGO PARAMETRU C PROCEDRA STANDARDOWA GENERACJI TABLICY MA NUMER 1 I PARAMETRY: C 0 - UPPER ,1 - LOWER,2 - APETYT,3 - ADRES VIRT.NOWEJ TABLICY CALL SPOP 100 CONTINUE C OBIE GRANICE WSTAWIONE. NA CZUBKU ZMIENNA.TABLICOWA? LSTLSE=0 C IF(STACK(VALTOP).EQ.0)GO TO 30 NO GLOBAL JUMPS IF(STACK(VALTOP).EQ.0)RETURN N=STACK(VALTOP-3) IF(N.EQ.0)GO TO 300 C O.K. WSTAW APETYT N=SAPET(N-1,STACK(VALTOP-4)) N=AUX(N) CALL QUADR4(145,SCONST(N),1,2) CALL QUADR2(132,1) C WYGENEROWANA NOWA TABLICA.ODCZYTAJ I WPISZ JEJ ADRES N=TSTEMP(4) CALL QUADR4(23,N,1,3) CALL SSTORE(VALTOP,N) RETURN C.....ERROR: ZMIENNA NIE JEST TYPU TABLICOWEGO 300 CALL SERROR(435) RETURN END SUBROUTINE SRESULT(ELEM) C----------------------------------------------------------------------------- C C POMOCNICZA. ZASTEPUJE 2 GORNE ELEMENTY STOSU PRZEZ ELEMENT C BEZ NAZWY TYPU ELEM. C JESLI TO NIE UNIWERSALNY,TO WSTAWIA TYP /0,TRESLT/, C ZERUJE SLOWO -5,DO SLOWA -2 WSTAWIA RESULT C UZYWANA DLA ZASTAPIENIA 2 ARGUMENTOW PRZEZ WYNIK /WARTOSC/ OPERACJI. C #include "stos.h" #include "blank.h" CALL SPOP CALL SPOP CALL SPUSH(ELEM) STACK(VALTOP-1)=0 IF(ELEM.EQ.0)RETURN STACK(VALTOP-2)=RESULT STACK(VALTOP-3)=0 STACK(VALTOP-4)=TRESLT STACK(VALTOP-5)=0 RETURN END SUBROUTINE SRESLT1(TYPE) C----------------------------------------------------------------------- C C ZASTEPUJE CZUBEK STOSU PRZEZ WARTOSC TYPU <0,TYPE> , C BEZ NAZWY, DO SLOWA -2 WSTAWIA RESULT, ZERUJE SLOWA -5,-6 C C #include "stos.h" #include "blank.h" C CALL SPOP CALL SPUSH(2) STACK(VALTOP-1)=0 STACK(VALTOP-2)=RESULT STACK(VALTOP-3)=0 STACK(VALTOP-4)=TYPE STACK(VALTOP-5)=0 STACK(VALTOP-6)=0 RETURN END SUBROUTINE SVARADR C---------------------------------------------------------------------- C C SPRAWDZA,CZY CZUBEK STOSU ZAWIERA ZMIENNA /ZMIENNA PROSTA, C ELEMENT TABLICY,TABLICA STATYCZNA/. C JESLI NIE, TO SYGNALIZUJE BLAD I ZASTEPUJE PRZEZ UNIWERSALNY. C GENERUJE KOD WYLICZAJACY ADRES FIZYCZNY ZMIENNEJ. C ATS WYLICZONEGO ADRESU ZWRACA NA ZMIENNA RESULT. C C ##### OUTPUT CODE : 29 , 30 . C C ##### DETECTED ERROR(S) : 420. C C #include "stos.h" #include "blank.h" C C IDL=STACK(VALTOP) C = RODZAJ ELEMENTU IF(IDL.EQ.0)RETURN IF(IDL.GT.5)GO TO 1000 GO TO (1000,1000,300,400,500),IDL C.....ZMIENNA 300 N=STACK(VALTOP-2) RESULT=TSTEMP(1) C PRZEZ KROPKE ? IF(STACK(VALTOP-7).EQ.0)GO TO 350 C ... ZMIENNA PRZEZ KROPKE CALL QUADR4(29,RESULT,SMEMBER(VALTOP),N) RETURN C ... ZMIENNA WIDOCZNA 350 CALL QUADR3(30,RESULT,N) RETURN C.....ELEMENT TABLICY 400 RESULT=SARRAY(VALTOP) RETURN C.....TABLICA STATYCZNA 500 CONTINUE C B R A K C.....NIE ZMIENNA 1000 CALL SERROR(420) C ZASTAP PRZEZ UNIWERSALNY CALL SPOP CALL SPUSH(0) STACK(VALTOP-1)=0 RETURN END SUBROUTINE SBOOLEX(N) C----------------------------------------------------------------------------- C C OBSLUGUJE 2-ARGUMENTOWE OPERACJE BOOLOWSKIE /N=1 --> AND, C =0 --> OR / C 2 GORNE ELEMENTY STOSU SA ARGUMENTAMI. C C C ##### OUTPUT CODE : 100 , 101 , 140 . C C ##### DETECTED ERROR(S) : 417 . C #include "stos.h" #include "option.h" #include "blank.h" CCCCCCCCCCCCCCCCCCCCCCC INTEGER ELEM,ANDOPR C SKOPIUJ PARAMETR ANDOPR=N CALL SVALU2 CALL SVALUE C.....USTAW TYP WYNIKU TRESLT=NRBOOL C ZBADAJ TYPY,NAJPIERW PRAWEGO. IF(STACK(VALTOP).NE.0) CALL SCHECK(417,NRBOOL) C SPRAWDZ LEWY ARGUMENT ELEM=0 IF(STACK(VLPREV).EQ.0)GO TO 120 IDR=VALTOP VALTOP=VLPREV C TRICK CALL SCHECK(417,NRBOOL) VALTOP=IDR IF(STACK(VALTOP).EQ.0)GO TO 120 C.....ZATEM OBA ARGUMENTY O.K. ARGUMENY STALE? CALL SARGMT GO TO (170,130,160,100),ARG C GENERUJ ZMIENNA ROBOCZA. 100 RESULT=TSTEMP(1) CALL QUADR4(100+ANDOPR,RESULT,STACK(VLPREV-2),STACK(VALTOP-2)) C 119 ELEM=2 C C.....ZASTAP PRZEZ WYNIK C 120 CALL SRESULT(ELEM) RETURN C C C.....LEWY ARGUMENT STALY,PRAWY NIE. C DALEJ BEDZIE: ELEM=ATS WARTOSCI LUB ZMIENNEJ, RESULT=WARTOSC STALEJ. 130 RESULT=STACK(VLPREV-2) ELEM=STACK(VALTOP-2) C.....WSPOLNA AKCJA DLA 1 ARGUMENTU STALEGO. ELEM,RESULT - JAK WYZEJ. 140 IF(ANDOPR.EQ.1 .AND. RESULT.EQ.-1 .OR. X ANDOPR.EQ.0 .AND. RESULT.EQ.0)GO TO 150 C.....AND,FALSE LUB OR,TRUE . C ZASTAP OBA WARTOSCIA RESULT, EWENT. GENERUJ NOP. IF(.NOT.OPTOPT)CALL QUADR2(140,ELEM) ELEM=1 GO TO 120 C.....AND,TRUE LUB OR,FALSE. ZASTAP OBA PRZEZ ROZNY OD STALEJ ARGUMENT. 150 RESULT=ELEM GO TO 119 C.....PRAWY STALY,LEWY NIE. 160 ELEM=STACK(VLPREV-2) RESULT=STACK(VALTOP-2) GO TO 140 C.....0BA STALE 170 RESULT=0 ELEM=STACK(VALTOP-2)+STACK(VLPREV-2) IF(ANDOPR.EQ.1 .AND. ELEM.EQ.-2 .OR. X ANDOPR.EQ.0 .AND. ELEM.NE.0) RESULT=-1 ELEM=1 GO TO 120 END SUBROUTINE SARGMT C----------------------------------------------------------------------- C C POMOCNICZA. BADA,CZY 2 GORNE ELEMENTY STOSU SA STALYMI. C NADAJE ZMIENNEJ ARG WARTOSC : C 1 - OBA STALE C 2 - LEWY STALY,PRAWY NIE C 3 - LEWY NIE,PRAWY STALY C 4 - OBA ROZNE OD STALYCH C #include "stos.h" #include "blank.h" C C ARG=1 IF(STACK(VALTOP).NE.1)ARG=2 IF(STACK(VLPREV).NE.1)ARG=ARG+2 RETURN END SUBROUTINE SINDEX C----------------------------------------------------------------------------- C C OBSLUGUJE KOLEJNY INDEKS DLA TABLICY DYNAMICZNEJ. C WOLANA PO WYSTAPIENIU "," LUB ")" C CZUBEK STOSU ZAWIERA INDEKS . C PONIZEJ ADRES TABLICY . C ZASTEPUJE 2 GORNE ELEMENTY STOSU PRZEZ "ELEM.TABLICY" . C C C C ##### DETECTED ERROR(S) : 431 . C #include "stos.h" #include "option.h" #include "blank.h" C common/stream/ errflg,line,ibuf2(265),ibuf3(7),junk(260) C.................. CALL SVALU2 C SPRAWDZ TYP INDEKSU CALL SINDTYP IF(STACK(VLPREV-3).GT.0)GO TO 200 C ZA DUZO INDEKSOW CALL SERRO2(431,VLPREV) GO TO 300 C O.K. 200 STACK(VLPREV-3)=STACK(VLPREV-3)-1 C ZASTAP PRZEZ "ELEM.TABLICY" 300 STACK(VLPREV)=4 STACK(VLPREV-7)= STACK(VALTOP-2) C WARTOSC INDEKSU. STALY? IF(STACK(VALTOP).EQ.1)STACK(VLPREV-2)= - STACK(VLPREV-2) RETURN END SUBROUTINE SINDTYP C---------------------------------------------------------------------- C C POMOCNICZA. SPRAWDZA,CZY CZUBEK STOSU ZAWIERA ELEMENT C SPROWADZALNY DO WARTOSCI TYPU INTEGER. C WYLICZA WARTOSC CZUBKA STOSU,DOKONUJE EWENTUALNEJ KONWERSJI DO INTEGER C WOLANA PRZEZ PROCEDURY SINDEX,SINDXS DLA KONTROLI INDEKSU C C ##### DETECTED ERROR(S) : 412 . C #include "stos.h" #include "blank.h" C C CALL SVALUE IF(STACK(VALTOP).EQ.0)RETURN C NIE UNIWERSALNY,SPRAWDZ TYP N=STACK(VALTOP-4) IF(STACK(VALTOP-3).GT.0 .OR. (N.NE.NRUNIV .AND. N.NE.NRINT X .AND. N.NE.NRRE) )GO TO 500 C O.K. IF(N.EQ.NRRE)CALL SVINT(VALTOP) RETURN C.....NIEPOPRAWNY TYP INDEKSU 500 CALL SERROR(412) RETURN END SUBROUTINE SASSIGN C----------------------------------------------------------------------------- C C WERSJA 1982.02.12 C C PROCEDURA OBSLUGUJE WIELOKROTNE PODSTAWIENIE. C WOLANA PRZEZ SDPDA PO POJAWIENIU SIE ASSIGN. C DOKONUJE KONTROLI TYPOW, GENERUJE KOD DYNAMICZNEJ KONTROLI C TYPOW I KONWERSJI ORAZ KOD NADAJACY WARTOSCI LEWYM STRONOM PODSTAWIENIA. C CZUBEK STOSU ZAWIERA PRAWA STRONE PODSTAWIENIA C PONIZEJ ,OD LSTFOR+1 DO LSTLSE ZNAJDUJA SIE LEWE STRONY PODSTAWIENIA C /UNIWERSALNY,ZMIENNA -MOZE BYC PRZEZ KROPKE-,ELEMTABLICY,TABL.STATYCZNA/. C WYROZNIA PRZYPADEK PODSTAWIENIA STALEJ REPREZENTOWANEJ PRZEZ ZERA. C C OBNIZA STOS , USTAWIA LSTLSE. C C C ##### OUTPUT CODE : 150 , 170 . C C C #include "stos.h" #include "option.h" #include "blank.h" C CCCCCCCCCCCCCCCCCCCCC INTEGER TYPL,TYPR C TYPL,TYPR - ATS-Y TYPOW LEWEJ,PRAWEJ STRONY /DLA KONTROLI DYNAMICZNEJ/ INTEGER VALUE,J,LSE C VALUE=ATS PRAWEJ STRONY LUB 0,GDY TO STALA REPREZENTOWANA PRZEZ ZERA C LSE=KOLEJNA LEWA STRONA C C............................................ CALL SVALUE C JESLI BRAK LEWYCH STRON LUB CZUBEK UNIWERSALNY-OBNIZ STOS IF(STACK(VALTOP).EQ.0 .OR. LSTLSE.LE.LSTFOR)GO TO 1000 C CZUBEK NIE JEST UNIWERSALNY,SA LEWE STRONY. C C.....OBEJRZYJ PRAWA STRONE PODSTAWIENIA TYPR=STACK(VALTOP-5) TYPL=0 VALUE=SVATS(VALTOP) C C................ KONIEC PRZYGOTOWAN. WYKONAJ W PETLI PODSTAWIENIE. C 400 LSE=VLPREV C C....................POCZATEK PETLI DLA KOLEJNYCH LEWYCH STRON C LSE WSKAZUJE KOLEJNA LEWA STRONE 500 IF(STACK(LSE).EQ.0)GO TO 900 C C ZBADAJ POPRAWNOSC PODSTAWIENIA TLDIM=STACK(LSE-3) TLBAS=STACK(LSE-4) OBJL=STACK(LSE-6) IDL=STACK(LSE-1) TRDIM=STACK(VALTOP-3) TRBAS=STACK(VALTOP-4) OBJR=STACK(VALTOP-6) J=1+MSUBST(1) C KONTROLA DYNAMICZNA? IF(J.GE.4 .AND. OPTTYP)GO TO 800 C KONWERSJA LUB KONTROLA DYNAMICZNA GO TO (800,610,620,630,640,650,660),J C C.....INTEGER:=REAL 610 CALL SVINT(VALTOP) VALUE=STACK(VALTOP-2) C JESLI STALA - WSTAW DO TABLICY SYMBOLI IF(STACK(VALTOP).EQ.1)VALUE=SCONST(VALUE) GO TO 800 C C.....REAL:=INTEGER 620 CALL SVREAL(VALTOP) VALUE=STACK(VALTOP-2) C JESLI STALA - WSTAW DO TABLICY SYMBOLI IF(STACK(VALTOP).EQ.1)VALUE=SCREAL(VALUE) GO TO 800 C C.....OBIE STRONY ZNANEGO TYPU 630 CALL QUADR3(150,VALUE,STACK(LSE-4)) GO TO 800 C C.....TYP LEWEJ FORMALNY,PRAWEJ ZNANY 640 IF(TYPR.EQ.0)TYPR=STYPST(VALTOP) GO TO 660 C C.....TYP LEWEJ ZNANY,PRAWEJ FORMALNY 650 TYPL=STYPST(LSE) GO TO 700 C C.....TYPY OBYDWU STRON FORMALNE 660 TYPL=STYPFT(LSE) GO TO 700 C C C..........KONTROLA DYNAMICZNA: TYPL,TYPR - TYPY LEWEJ,PRAWEJ STRONY 700 CALL QUADR4(170,TYPL,VALUE,TYPR) C C.....WPISZ WARTOSC C 800 CALL SSTORE(LSE,VALUE) C....................ZAKONCZENIE PETLI: C CZY JEST KOLEJNE LSE? 900 J=STACK(LSE) LSE=LSE-STCKAP(J) IF(LSE.GT.LSTFOR)GO TO 500 C.................... OBNIZANIE STOSU 1000 CONTINUE 1020 CALL SPOP IF(VALTOP.GT.LSTFOR)GO TO 1020 LSTLSE=0 RETURN END