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 SPARAM
C-----------------------------------------------------------------------------
C
C     WERSJA 1982.09.16
C
C     OBSLUGUJE TRANSMISJE I KONTROLE PARAMETRU AKTUALNEGO.
C     NA CZUBKU STOSU JEST PARAMETR AKTUALNY, PONIZEJ WOLANA FUNKCJA,
C      PROCEDURA,KLASA,REKORD,BLOK PREFIKSOWANY.
C     PO OBSLUZENIU PARAMETRU ZDEJMUJE GO ZE STOSU.
C     NIE WOLA SNEXT.
C
C     UZYWANA ROWNIEZ DLA PROCEDUR I FUNKCJI STANDARDOWYCH.
C	   / TYLKO PARAMETRY INPUT, OUTPUT, IN-OUT / .
C
C
C     KOLEJNOSC OBSLUGI PARAMETRU :
C	 1) WOLA MPKIND OKRESLAJACE RODZAJ PARAMETRU :
C	       0 - UNIWERSALNY
C	       1 - INPUT
C	       2 - OUTPUT
C	       3 - TYPE
C	       4 - FUNKCJA
C	       5 - PROCEDURA
C	       6 - IN-OUT
C	   I PRZYPISUJE PARAM ADRES OPISU PAR.FORMALNEGO W IPMEM
C
C	 2) JESLI PAR.FORMALNY JEST UNIWERSALNY LUB PAR.AKTUALNY JEST
C	    UNIWERSALNY LUB NIEWLASCIWEGO RODZAJU, A PAR.FORM. <> "TYPE"  -
C	      NIE ROBI NIC    /POZA SYGNALIZACJA BLEDU/
C
C	 3) DLA PAR. INPUT : WOLA MPARIO /BADA ZGODNOSC TYPOW/ ,GENERUJE KOD
C	      EWENT. KONWERSJI LUB KONTROLI DYNAMICZNEJ I WPISUJE WARTOSC PAR.
C	      AKTUALNEGO DO GENEROWANEGO POLA DANYCH /DLA STALYCH REPREZENTO-
C	       WANYCH PRZEZ ZERA NIE WPISUJE NICZEGO/.
C		DLA PROCEDURY,FUNKCJI STANDARDOWEJ NIE WPISUJE WARTOSCI
C		 PARAMETRU, LECZ ZAMIENIA NA STOSIE PARAMETR I PROCEDURE
C		 /FUNKCJE/ MIEJSCAMI, DZIEKI CZEMU PROCEDURA JEST NA STOSIE
C		 NAD WSZYTKIMI JUZ PRZETWORZONYMI PARAMETRAMI INPUT.
C
C
C	    DLA PAR. OUTPUT : WOLA MPARIO,ZABEZPIECZA ADRES ZMIENNEJ /ADR.
C		TABLICY I INDEKS,ADR. PRZED KROPKA/ I TYP FORMALNY,WPISUJE
C		OPIS PARAMETRU NA STOS I ZWIEKSZA LICZNIK PARAMETROW OUTPUT
C		/JESLI BRAK MIEJSCA NA OPIS - NIE ZWIEKSZA/
C
C	    DLA PAR. TYPE : WOLA MPARTP / ZAWSZE! ,DLA PAR.AKT. NIEPOPRAWNEGO
C		LUB UNIWERSALNEGO PODAJE NRUNIV/ I WPISUJE TYP DO POLA DANYCH
C
C	    DLA PAR. FUNCTION,PROCEDURE : WOLA MPARPF ,
C		    USTAWIA KIND , WOLA SPRFLD /GENERUJACA PROTOTYP
C		  WRAZ Z OTOCZENIEM/
C	     WPISUJE PROTOTYP I OTOCZENIE PAR.AKTUALNEGO DO POLA DANYCH,
C	       EW. GENERUJE DYNAMICZNA	KONTROLE ZGODNOSCI NAGLOWKOW.
C
C	    DLA PAR. IN-OUT : NAJPIERW OBSLUGUJE GO JAK PAR. OUTPUT,
C		       A NASTEPNIE JAK PAR.INPUT
C
C     UZYWA: PHADR , NRPAR
C
C
C     # OUTPUT CODE : 43 , 52 , 144 , 150 , 161 , 162 , 163 ,
C			 164 , 165 , 166 , 170 .
C
C     ##### DETECTED ERROR(S) : 470 , 471 , 472 , 473 , 474 , 478 , 550 .
C
C
#include "stos.h"
#include "option.h"
#include "blank.h"
CCCCCCCCCCCCCCCCCCCCCC
      INTEGER PARAM,APET,CONTRL,ATS,LNRPAR,PARKIND,ELEM
C     PARAM = ADRES W IPMEM OPISU PARAMETRU FORMALNEGO
C     APET = LICZBA SLOW NA PARAMETR FORMALNY
C     CONTRL = INFORMACJA O KONWERSJI LUB KONTROLI DYNAMICZNEJ
C     ATS = ATS WARTOSCI PAR. LUB ADR.FIZYCZNY DLA NIEZNANEGO OFFSETU
C     PARKIND = RODZAJ PAR.FORMALNEGO, 1..7 ,=MPKIND( )+1
C     ELEM = RODZAJ ELEMNTU Z CZUBKA STOSU
C
      LOGICAL DCONTR
      DATA SPARAHEX /x'0800'/
C     =.TRUE. JESLI KONIECZNA DYNAMICZNA KONTROLA NAGLOWKOW PROC.,FUNC.
C
C...............
      DCONTR=.FALSE.
C     RODZAJ PAR.AKTUALNEGO ?
      ELEM=STACK(VALTOP)
C     RODZAJ PAR.FORMALNEGO ?
      PARKIND=MPKIND(PARAM)+1
C     JESLI PAR.AKTUALNY UNIWERSALNY-POMIN
      IF(ELEM.EQ.0.AND. PARKIND.NE.4)GO TO 9905
      GO TO(9905,1000,2000,3000,4000,4000,2000),PARKIND
C
C
C
C- - - - - - - - - - PAR. I N - O U T - - - - - - -
C
C     ZMIEN KWALIFIKACJE NA INPUT /KOD ODCZYTUJACY WARTOSC JUZ WYGENEROWANY/
C
  990 PARKIND=2
C
C
C-------------------- PAR. I N P U T ------------
C     CZY POPRAWNY PAR. AKTUALNY?
 1000 IF(ELEM.LT.6 .OR. ELEM.EQ.12)GO TO 1003
C     NIEPOPRAWNY PAR. AKTUALNY
      PARAM=470
      GO TO 9600
 1003 LNRPAR=NRPAR
C     PRZECHOWAJ NUMER PARAMETRU: NA CZUBKU MOZE BYC FUNKCJA BEZPARAMETROWA,
C     ODCZYT JEJ WARTOSCI MOZE ZNISZCZYC NRPAR
      CALL SVALUE
      NRPAR=LNRPAR
C     SPRAWDZ ZGODNOSC TYPOW
      CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
     X STACK(VALTOP-6))
      APET=SAPET(IPMEM(PARAM-4),IPMEM(PARAM-3))
      IF(CONTRL.EQ.1)CALL SVINT(VALTOP)
      IF(CONTRL.EQ.2)CALL SVREAL(VALTOP)
      ATS=STACK(VALTOP-2)
C     ATS WARTOSCI PARAMETRU
C.....FUNKCJA,PROCEDURA STANDARDOWA ?
      IF(STACK(VLPREV-4).LT.LPMSYS)GO TO 1800
C     NIE.
      CALL SPHADR(VLPREV)
C     CZY PAR.AKTUALNY JEST STALA?
      IF(ELEM.EQ.1)GO TO (1007,1008,9905,9905),APET
C
C     PARAMETR NIE JEST STALA
      APET=APETYT(APET)
      GO TO 1050
C
C
C.....PAR.AKTUALNY JEST STALA. JESLI REPREZENTOWANA PRZEZ ZERA - NIC NIE
C	ROB /INICJALIZACJA POLA WPISALA ZERA/
C ... APETYT 1 ( INTEGER,BOOLEAN,CHAR,STRING )
 1007 IF(ATS.EQ.0)GO TO 9905
C     WSTAW STALA INTEGER,SKOCZ DO WPISANIA WARTOSCI PARAMETRU
      ATS=SCONST(ATS)
      GO TO 9750
C ... APETYT 2 ( REAL - TYP FORMALNY TU NIE WYSTAPI )
cdsw&bc    1008 IF(STALER(ATS).EQ. 0.0)GO TO 9905
 1008 continue
c
C     WSTAW STALA REAL, SKOCZ DO WPISANIA WARTOSCI
      ATS=SCREAL(ATS)
      GO TO 9750
C
C
C.....JESLI NIEPOTRZEBNA KONTROLA DYNAMICZNA - WPISZ WARTOSC
 1050 IF(CONTRL.LT.3 .OR. OPTTYP)GO TO 9750
      CONTRL=CONTRL-2
C
      IDR=STACK(VALTOP-5)
C     IDR = ZMODYFIKOWANY TYP FORMALNY PARAMETRU AKTUALNEGO LUB ZERO
C
C     CZY ZNANY OFFSET? /NIE,JESLI TO VIRTUAL LUB PARAMETR/
      IF(STACK(VLPREV-3).GE.16384)GO TO 1500
C
C
C.....ZNANY OFFSET PARAMETRU.
C
      GO TO(1100,1200,1300,1400),CONTRL
C.....KONTROLA DYNAMICZNA, OBA TYPY ZNANE
 1100 CALL QUADR3(150,ATS,IPMEM(PARAM-3))
      GO TO 9800
C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST FORMALNY,AKTUALNEGO ZNANY
 1200 IDR=STYPST(VALTOP)
      GO TO 1400
C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST ZNANY,AKTUALNEGO FORMALNY
 1300 N=SPARST(PARAM)
      GO TO 1450
C.....KONTROLA DYN.,TYPY PAR.FORMALNEGO I AKTUALNEGO SA FORMALNE
cdsw 1400 N=SPARFT(PARAM)
cdsw  -----------------------
 1400 n = sparft(param,1)
cdsw  ------------------------
 1450 CALL QUADR4(170,N,ATS,IDR)
      GO TO 9800
C
C
C..............NIEZNANY OFFSET PARAMETRU.
C		     - TYP PAR.FORMALNEGO TRZEBA ODCZYTAC
C     IDL,IDR = TYPY PAR.FORMALNEGO I AKTUALNEGO
 1500 CALL SPHADR(VLPREV)
      IF(CONTRL.LT.3)IDR=STYPST(VALTOP)
      CALL QUADR4(170,SFPRST(NRPAR),ATS,IDR)
      GO TO 9700
C
C.........PARAMETR INPUT PROCEDURY, FUNKCJI STANDARDOWEJ.
C     ZAMIEN MIEJSCAMI OPISY PARAMETRU I FUNKCJI, TAK , BY FUNKCJA
C	BYLA NAD SWOIMI ARGUMENTAMI.  / OBA OPISY ZAJMUJA PO 8 SLOW /
C
 1800 DO 1810 K=0,7
	 IDR=VALTOP-K
	 IDL=VLPREV-K
	 N=STACK(IDR)
	 STACK(IDR)=STACK(IDL)
	 STACK(IDL)=N
 1810 CONTINUE
C     NA CZUBKU JEST FUNKCJA,PROCEDURA STANDARDOWA
C     ZWIEKSZ LICZNIK PARAMETROW INPUT /SLOWO -2/
      STACK(VALTOP-2)=STACK(VALTOP-2)+1
C     WPISZ NUMER PARAMETRU DO SLOWA -1
      STACK(VLPREV-1)=NRPAR
      RETURN
C
C
C-------------------- PAR. O U T P U T ---------------
C
C     CZY PAR. AKTUALNY TO LSE?
 2000 IF(ELEM.GT.2 .AND. ELEM.LT.6)GO TO 2005
C     NIEPOPRAWNY PARAMETR /AKTUALNY/ OUTPUT
      PARAM=471
      GO TO 9600
C      O.K.	  SPRAWDZ ZGODNOSC TYPOW
 2005 CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
     X	  STACK(VALTOP-6))
C     ZABEZPIECZ ADRES ZMIENNEJ
      CALL SAVEVAR(VALTOP)
C.....WPISZ OPIS PARAMETRU AKTUALNEGO. CZY JEST MIEJSCE?
      IF(FSTOUT-VALTOP.GE.11)GO TO 2110
C      BRAK MIEJSCA NA STOSIE NA DODATKOWE INFORMACJE O PARAMETRZE.
      PARAM=550
      GO TO 9600
C     O.K. JEST MIEJSCE
 2110 CONTINUE
C     ZWIEKSZ LICZNIK PARAMETROW OUTPUT
      STACK(VLPREV-3)=STACK(VLPREV-3)+1
C     POSTAC OPISU PARAMETRU OUTPUT:
C	     OPIS ZAJMUJE 11 SLOW, OZNACZONYCH -9,..,0,+1
C	     SLOWA -9..0 ZAWIERAJA PRZEPISANY PAR.AKTUALNY
C	      /DLA ZMIENNEJ I ELEM.TABLICY SLOWA -9,-8 POZOSTAJA
C	       NIEWYKORZYSTANE/
C	     SLOWO -1 ZAMIAST NAZWY ZAWIERA ADRES W IPMEM OPISU PARAMETRU
C		      FORMALNEGO
C	     SLOWO +1 = NUMER PARAMETRU /NRPAR/
C	     SLOWO 0 W BITACH 9-11 INFORMACJE O KONTROLI /MPARIO(..)/
C
C     WPISZ NUMER PARAMETRU
      STACK(FSTOUT-1)=NRPAR
C     WPISZ RODZAJ ELEMENTU Z INFORMACJA O KONTROLI W BITACH 9-11
      STACK(FSTOUT-2)=ELEM+CONTRL*16
C     WPISZ ADRES OPISU PAR.FORMALNEGO
      STACK(FSTOUT-3)=PARAM
C     PRZEPISZ POZOSTALE 8 SLOW /BYC MOZE OSTATNIE 2 TO SMIECIE/
C     APET,CONTRL = DOLNY,GORNY INDEKS
      APET=VALTOP-2
      CONTRL=FSTOUT-4
 2115 STACK(CONTRL)=STACK(APET)
      APET=APET-1
      CONTRL=CONTRL-1
      IF(CONTRL.GT.FSTOUT-12)GO TO 2115
C     SLOWA VALTOP-0,..,VALTOP-9 PRZEPISANE NA MIEJSCA FSTOUT-2,..,FSTOUT-11.
C
      FSTOUT=FSTOUT-11
      GO TO 9905

C
C-------------------- PAR. T Y P E ---------------------
C
C     CZY PAR.AKTUALNY TO NAZWA TYPU,REKORD,KLASA?
 3000 IF(ELEM.LT.7 .OR. ELEM.GT.9)GO TO 3800
C     O.K.
      CALL MPARTP(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-6),
     X	       STACK(VALTOP-1))
C     POBIERZ TYP
      ATS=STACK(VALTOP-2)
C     =0 : KLASA,REKORD,TYP PIERWOTNY
C     >0 : ATS WARTOSCI PAR.TYPE LUB PARAMETRU TYPE
      IF(ATS.EQ.0)ATS=STYPST(VALTOP)
      APET=2
      GO TO 9750
C
C.....UNIWERSALNY LUB NIEPOPRAWNY PARAMETR TYPE
 3800 CALL MPARTP(0,NRUNIV,0,STACK(VALTOP-1))
      IF(ELEM.EQ.0)GO TO 9905
      PARAM=472
      GO TO 9600
C
C------------- PAR. F U N C T I O N , P R O C E D U R E ------
C
C     CZY PAR.AKTUALNY JEST FUNKCJA LUB PROCEDURA?
 4000 IF(ELEM.EQ.11 .OR. ELEM.EQ.12)GO TO 4010
C     NIEPOPRAWNY PAR. AKTUALNY
      PARAM=479-PARKIND
C     = 473 LUB 474
      GO TO 9600
C     FUNKCJA LUB PROCEDURA.
 4010 APET=STACK(VALTOP-4)
C      = ADRES OPISU FUNKCJI,PROCEDURY
C     CZY PAR.AKTUALNY JEST FUNKCJA,PROCEDURA STANDARDOWA ?
      IF(APET.GE.LPMSYS)GO TO 4020
C     NIESTETY, TAK.
      PARAM=478
      GO TO 9600
 4020 CALL MPARPF(APET,STACK(VALTOP-1),STACK(VALTOP-6),DCONTR)
C     JAKIEGO RODZAJU?
      KIND=0
C     WEZ ZEROWE SLOWO OPISU
      APET=IPMEM(APET)
C     VIRTUALNA,JESLI BIT 4 = 1
      IF(IAND(APET,SPARAHEX).NE.0)KIND=1
C      LUB FORMALNA , JESLI BITY 8..11 = 2 LUB 3. WEZ TE BITY
      APET=IAND(ISHFT(APET,-4),15)
      IF(APET.EQ.2 .OR. APET.EQ.3)KIND=2
C     WYLICZ NUMER PROTOTYPU I OJCA SYNTAKTYCZNEGO PARAMETRU
      ATS=SPRFLD(.TRUE.)
      APET=3
      GO TO 9750
C
C
C
C-------------------------------
C
C
C.....WSPOLNA SYGNALIZACJA BLEDU.
C     PARAM= NUMER BLEDU
 9600 CALL SERROR(PARAM)
      GO TO 9905
C
C
C.....WPISANIE WARTOSCI PARAMETRU Z NIEZNANYM OFFSETEM
 9700 CONTRL=TSTEMP(1)
      CALL SPHADR(VLPREV)
C     WEZ ADRES FIZYCZNY PARAMETRU
      CALL QUADR4(52,CONTRL,PHADR,NRPAR)
C     WPISZ WARTOSC POD TEN ADRES
      CALL QUADR3(160+APET,CONTRL,ATS)
      GO TO 9900
C
C.....WPISANIE WARTOSCI. CZY ZNANY OFFSET?
 9750 IF(STACK(VLPREV-3).GE.16384)GO TO 9700
C
C.....WPISANIE WARTOSCI PARAMETRU ZE ZNANYM OFFSETEM
 9800 CONTINUE
      CALL SPHADR(VLPREV)
      CALL QUADR4(163+APET,PHADR,ATS,PARAM)
C     WPISZ APET-SLOW DO POLA WSKAZANEGO PRZEZ ADRES FIZYCZNY PHADR
C
C
C.....JUZ PO WSZYSTKIM-LUB PARAMETR UNIWERSALNY.
C     CZY DYNAMICZNA KONTROLA NAGLOWKOW?
 9900 IF(.NOT.DCONTR)GO TO 9905
C     TAK. ODTWORZ PELNY ADRES VIRTUALNY Z AH
      APET=TSTEMP(4)
      CALL QUADR3(43,APET,STACK(VLPREV-2))
      STACK(VLPREV-2)=APET
      CALL QUADR3(144,APET,NRPAR)
      PHADR=0
C
C
C ... JESLI TO IN-OUT ,TO POTRAKTUJ GO TERAZ JAK INPUT
 9905 IF(PARKIND.EQ.7)GO TO 990
      CALL SPOP
C
      RETURN
      END
      SUBROUTINE SVALU2
C-----------------------------------------------------------------------------
cdsw  procedura podzielona na svalue i svalue2 - entry usuniete
C
C     ENTRY SVALUE
C
C
C     SPRAWDZA,CZY ELEMENT Z CZUBKA STOSU /SVALUE/ LUB PONIZEJ /SVALU2/
C     REPREZENTUJE WARTOSC I WYLICZA TE WARTOSC.
C     "UNIWERSALNY","STALA","WARTOSC" ZOSTAWIA BEZ ZMIAN.
C     "ZMIENNA","ELEMTABLICY","TABLICA STATYCZNA","FUNKCJA"/BEZPARAMETROWA/
C	ZASTEPUJE PRZEZ "WARTOSC" I JESLI SA TYPU FORMALNEGO TO POBIERA
C     TEN TYP.	NIE MODYFIKUJE GO O LICZBE ARRAY-OF.
C     POZOSTALE ZASTEPUJE PRZEZ "UNIWERSALNY" SYGNALIZUJAC BLAD.
C
C	WEJSCIE SVALUE - DLA CZUBKA STOSU
C	WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
C
C     ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
C
C     ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
C
#include "stos.h"
#include "blank.h"
CCCCCCCCCCCCCCCCCCCC
      INTEGER ER(8)
C      NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
C
      INTEGER ATS,ELEM,APET
      DATA ER/452,451,451,0,450,0,453,454/
C
      K=VLPREV
  100 ELEM=STACK(K)-2
C     JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
      IF(ELEM.LE.0)RETURN
C
C     JESLI TYPU FORMALNEGO - WEZ TEN TYP
      IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
C
C     ZMIENNA PROSTA?
      IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
      IF(ELEM.GT.3)GO TO 600
C
C     WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
      APET=SAPET2(K)

#if WSIZE == 4
cvax  changed because of real appettite = 1
      dswap = apet
      if (dswap .eq. 2) dswap = 1
      ats = tstemp(dswap)
#else
      ATS=TSTEMP(APET)
#endif

      APET=APETYT(APET)
      GO TO (300,400,500),ELEM
C.....ZMIENNA PRZEZ KROPKE. ODCZYTAJ APET-SLOW.
  300 CALL QUADR4(83+APET,ATS,SMEMBER(K),STACK(K-2))
C     ZASTAP PRZEZ WARTOSC
  340 STACK(K-2)=ATS
  350 STACK(K)=2
      RETURN
C
C.....ELEM. TABLICY
  400 CALL QUADR3(60+APET,ATS,SARRAY(K))
      GO TO 340
C
C.....TABLICA STATYCZNA
  500 CONTINUE
C     B R A K
C...........
C     JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
  600 IF(ELEM.NE.10)GO TO 3000
C     FUNKCJA. /BEZPARAMETROWA/
      CALL SCALLB
C     I TO WSZYSTKO.
      RETURN
C
C.....OBSLUGA BLEDOW
 3000 ELEM=ER(ELEM-4)
      CALL SERRO2(ELEM,K)
C     ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
      STACK(K)=0
      RETURN
      END
      SUBROUTINE SVALUE
C-----------------------------------------------------------------------------
cdsw  procedura podzielona na svalue i svalue2 - entry usuniete
C
C     ENTRY SVALUE
C
C
C     SPRAWDZA,CZY ELEMENT Z CZUBKA STOSU /SVALUE/ LUB PONIZEJ /SVALU2/
C     REPREZENTUJE WARTOSC I WYLICZA TE WARTOSC.
C     "UNIWERSALNY","STALA","WARTOSC" ZOSTAWIA BEZ ZMIAN.
C     "ZMIENNA","ELEMTABLICY","TABLICA STATYCZNA","FUNKCJA"/BEZPARAMETROWA/
C	ZASTEPUJE PRZEZ "WARTOSC" I JESLI SA TYPU FORMALNEGO TO POBIERA
C     TEN TYP.	NIE MODYFIKUJE GO O LICZBE ARRAY-OF.
C     POZOSTALE ZASTEPUJE PRZEZ "UNIWERSALNY" SYGNALIZUJAC BLAD.
C
C	WEJSCIE SVALUE - DLA CZUBKA STOSU
C	WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
C
C     ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
C
C     ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
C
#include "stos.h"
#include "blank.h"
CCCCCCCCCCCCCCCCCCCC
      INTEGER ER(8)
C      NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
C
      INTEGER ATS,ELEM,APET
      DATA ER/452,451,451,0,450,0,453,454/
      K=VALTOP
  100 ELEM=STACK(K)-2
C     JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
      IF(ELEM.LE.0)RETURN
C
C     JESLI TYPU FORMALNEGO - WEZ TEN TYP
      IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
C
C     ZMIENNA PROSTA?
      IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
      IF(ELEM.GT.3)GO TO 600
C
C     WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
      APET=SAPET2(K)

#if WSIZE == 4
cvax  changed with real appetite = 1
      dswap = apet
      if (dswap .eq. 2) dswap = 1
      ats = tstemp(dswap)
#else
      ATS=TSTEMP(APET)
#endif
 
      APET=APETYT(APET)
      GO TO (300,400,500),ELEM
C.....ZMIENNA PRZEZ KROPKE. ODCZYTAJ APET-SLOW.
  300 CALL QUADR4(83+APET,ATS,SMEMBER(K),STACK(K-2))
C     ZASTAP PRZEZ WARTOSC
  340 STACK(K-2)=ATS
  350 STACK(K)=2
      RETURN
C
C.....ELEM. TABLICY
  400 CALL QUADR3(60+APET,ATS,SARRAY(K))
      GO TO 340
C
C.....TABLICA STATYCZNA
  500 CONTINUE
C     B R A K
C...........
C     JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
  600 IF(ELEM.NE.10)GO TO 3000
C     FUNKCJA. /BEZPARAMETROWA/
      CALL SCALLB
C     I TO WSZYSTKO.
      RETURN
C
C.....OBSLUGA BLEDOW
 3000 ELEM=ER(ELEM-4)
      CALL SERRO2(ELEM,K)
C     ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
      STACK(K)=0
      RETURN
      END
      SUBROUTINE SVINT(ELEM)
C-----------------------------------------------------------------------------
C
C     POMOCNICZA. ZASTEPUJE ELEMENT Z MIEJSCA ELEM STOSU /STALA,
C     WARTOSC,ZMIENNA/ TYPU REAL PRZEZ STALA LUB WARTOSC TYPU INTEGER.
C     GENERUJE KOD KONWERSJI.
C     W PRZYPADKU STALEJ REAL O WARTOSCI WYKRACZAJACEJ POZA ZAKRES LICZB
C      CALKOWITYCH SYGNALIZUJE ERROR 408  I ZASTEPUJE PRZEZ STALA INTEGER
C	O TYM SAMYM ZNAKU I NAJWIEKSZYM MOZLIWYM MODULE.
C
C     ##### OUTPUT CODE : 58 .
C
C     ##### DETECTED ERROR(S) : 408 .
C
C
#include "stos.h"
#include "blank.h"
C
C
      REAL  X
      real y
      integer*2 m(2)
      equivalence (y, m(1))
C
#if WSIZE == 4
      DATA MAXINTEGER,MININTEGER / x'7FFFFFFF', x'80000000' /
#else
      DATA MAXINTEGER,MININTEGER / x'7FFF', -x'7FFF' /
#endif
C
C
C.....
      STACK(ELEM-4)=NRINT
C     CZY STALA?
      IF(STACK(ELEM).NE.1)GO TO 100
C     TAK
      N=STACK(ELEM-2)
C     SPRAWDZ WARTOSC STALEJ
#if WSIZE == 4
      X=STALER(N)
#else
      n1 = n*2-1
      m(1) = ipmem(n1)
      m(2) = ipmem(n1+1)
      x = y
#endif
c
      IF(X.LT.FLOAT(MININTEGER) .OR. X.GT.FLOAT(MAXINTEGER))GO TO 200
CJF	 STACK(ELEM-2)=IFIX(X)
cdsw  STACK(ELEM-2)= IIDINT(X)
      stack(elem-2) = ifix(x)
      RETURN
C     WARTOSC LUB ZMIENNA;    GENERUJ KONWERSJE
  100 N=TSTEMP(1)
      CALL QUADR3(58,N,STACK(ELEM-2))
      STACK(ELEM-2)=N
      STACK(ELEM)=2
      RETURN
C     STALA REAL O WARTOSCI POZA ZAKRESEM LICZB CALKOWITYCH
  200 CALL SERRO2(408,ELEM)
C     ZASTAP PRZEZ NAJWIEKSZA LICZBE CALKOWITA
      N=MAXINTEGER
      IF(X.LT.0.0)N=MININTEGER
      STACK(ELEM-2)=N
      RETURN
      END
      SUBROUTINE SVREAL(ELEM)
C-----------------------------------------------------------------------------
C
C     POMOCNICZA. ZASTEPUJE ELEMENT /STALA,WARTOSC,ZMIENNA/ Z MIEJSCA
C     ELEM STOSU TYPU INTEGER PRZEZ STALA LUB WARTOSC TYPU REAL.
C
C     ##### OUTPUT CODE : 59 .
C
C
#include "stos.h"
#include "blank.h"
C
C
      STACK(ELEM-4)=NRRE
C     CZY TO STALA?
      IF(STACK(ELEM).NE.1)GO TO 100
C     TAK
      STACK(ELEM-2)=CREAL(FLOAT(STACK(ELEM-2)))
      RETURN
C     WARTOSC,ZMIENNA;	      GENERUJ KONWERSJE
#if WSIZE == 4
100   n = tstemp(1)
#else
100   n = tstemp(2)
#endif
      CALL QUADR3(59,N,STACK(ELEM-2))
      STACK(ELEM-2)=N
      STACK(ELEM)=2
      RETURN
      END
      SUBROUTINE SPUSH(ELEM)
C------------------------------------------------------------------------
C
C     WSTAWIA NA STOS ELEMENT TYPU ELEM. USTAWIA VALTOP,VLPREV.
C
C     PRZY PRZEPELNIENIU STOSU PRZERYWA KOMPILACJE !!!
C
C     ( NA SKUTEK BRAKU NIELOKALNYCH SKOKOW NIE JEST MOZLIWY  )
C     ( SKOK DO ETYKIETY 2000 W SPASS2 I KOMPILACJA KOLEJNYCH )
C     ( MODULOW.					      )
C
C
C     ##### DETECTED ERROR(S) : 550.   /PRZEPELNIENIE STOSU  /
C
C
#include "stos.h"
#include "blank.h"
      VLPREV=VALTOP
      VALTOP=VALTOP+STCKAP(ELEM)
      IF(VALTOP.GE.FSTOUT)GO TO 100
      STACK(VALTOP)=ELEM
      RETURN
C.....PRZEPELNIENIE STOSU
  100 CALL MERR(550,0)
C     GO TO 2000   CHANGED TO COMMENT DUE TO A.I.L./P.G.     15.05.84
      call ffexit
C     FOR STACK BEING OVERLOADED  STOP THE COMPILATION
C     ' FATAL ERROR  '
      END
      SUBROUTINE SPOP
C--------------------------------------------------------------------------
C
C     ZDEJMUJE 1 ELEMENT Z CZUBKA STOSU. USTAWIA VALTOP, VLPREV.
C
C
#include "stos.h"
#include "blank.h"
C
      COMMON/SUMMARY/FREE
C
C
      N=FSTOUT-VALTOP-1
      IF(N.LT.FREE)FREE=N
C
      VALTOP=VLPREV
      IF(VALTOP.LT.LSTSAF)LSTSAF=VALTOP
      VLPREV=STACK(VALTOP)
      VLPREV=STCKAP(VLPREV)
C     =APETYT NOWEGO CZUBKA STOSU
      VLPREV=VALTOP-VLPREV
      RETURN
      END
      INTEGER FUNCTION SCONST(N)
C-----------------------------------------------------------------------------
C
C     POMOCNICZA.
C     ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA O WARTOSCI N.
C
C     ##### OUTPUT CODE : 199 .
C
C
#include "stos.h"
C
C.....
      LSTEMP=LSTEMP-3
      SCONST=LSTEMP
      CALL QUADR3(199,SCONST,N)
      IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
      RETURN
      END
      INTEGER FUNCTION CREAL(X)
C----------------------------------------------------------------
C
C     ZWRACA ADRES STALEJ X TYPU REAL W TABLICY STALYCH
C
C     ##### DETECTED ERROR(S) : 554 .
C
      IMPLICIT INTEGER (A-Z)
#include "blank.h"
C
C
      REAL   X

#if WSIZE == 4
cvax  data realsize/1/
cvax  the size of real numbers on vax is 4 bytes ( = the size of integer)
      i = lpmem+1
100   if (staler(i) .eq.x) goto 200
      i = i+1
cail      if (i .lt. irecn) goto 100
      if (i .le. irecn) goto 100
Cail  constant not found, i=irenc+1, append if enough room
      if (irecn+1 .gt. ipmem(lmem)) goto 300
      irecn = irecn + 1
      staler(i) = x
200   creal = i
#else
      real y
      integer*2 m(2)
      equivalence (y, m(1))
      INTEGER REALSIZE
      DATA REALSIZE/2/
      y = x
      i = lpmem + 1
  100 if (ipmem(i) .eq. m(1) .and. ipmem(i+1) .eq. m(2)) goto 200
      i = i + 2
      if (i .lt. irecn) goto 100
      if (irecn + 2 .gt. ipmem(lmem)) goto 300
      irecn = irecn + 2
      ipmem(i  ) = m(1)
      ipmem(i+1) = m(2)
  200 creal = (i+1) / 2
      n1 = creal*2-1
      m(1) = ipmem(n1)
      m(2) = ipmem(n1+1)
#endif

cdsw&bc C		      = SIZE OF REAL VALUE (NUMBER OF WORDS)
cdsw&bc C     LPMEM=INDEKS OSTATNIEGO SLOWA PRZEZ STALYMI REAL
cdsw&bc C     IRECN=INDEKS OSTATNIEGO SLOWA ZAJETEGO PRZEZ STALE REAL
cdsw&bc       N=(IRECN / REALSIZE)+1
cdsw&bc C	 = INDEKS PIERWSZEGO WOLNEGO MIEJSCA W STALER
cdsw&bc       CREAL=(LPMEM+REALSIZE-1)/REALSIZE+1
cdsw&bc C	 = INDEKS PIERWSZEJ STALEJ W STALER
cdsw&bc C     USTAW WARTOWNIKA
cdsw&bc       STALER(N)=X
cdsw&bc   100 IF(STALER(CREAL).EQ.X)GO TO 200
cdsw&bc       CREAL=CREAL+1
cdsw&bc       GO TO 100
cdsw&bc C     JEST?
cdsw&bc   200 IF(CREAL.LT.N)RETURN
cdsw&bc       IF(IRECN+REALSIZE .GT. IPMEM(LMEM))GO TO 300
cdsw&bc       IRECN=IRECN+REALSIZE
      RETURN
  300 CALL SERRO2(554,0)
      RETURN
      END
      INTEGER FUNCTION SCREAL(N)
C----------------------------------------------------------------------------

C     POMOCNICZA.
C     ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA REAL O NUMERZE N
C
C     ##### OUTPUT CODE : 197 .
C
#include "stos.h"
#include "blank.h"
C
C
#if WSIZE == 4
      data realsize /1/
#else
      data realsize /2/
#endif

C		      = SIZE OF REAL VALUE (NUMBER OF WORDS)
C     LPMEM=INDEKS OSTATNIEGO SLOWA PRZEZ STALYMI REAL
C.....
      LSTEMP=LSTEMP-3
      SCREAL=LSTEMP
      K=(LPMEM+REALSIZE-1)/REALSIZE+1
C     K=INDEKS PIERWSZEJ STALEJ W STALER
      K=REALSIZE*(N-K)
C	= OFFSET WZGLEDEM ETYKIETY "RECON" RUN-TIME-U.
      CALL QUADR3(197,SCREAL,K)
      IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
      RETURN
      END

      INTEGER FUNCTION SWHAT(IND)
C----------------------------------------------------------------------------
C
C
C     IND WSKAZUJE ZEROWE SLOWO OPISU ATRYBUTU /IND=MIDENT(NAZWA)/.
C     FUNKCJA ROZPOZNAJE RODZAJ ATRYBUTU I ZWRACA JAKO WYNIK :
C		    0 - "UNIWERSALNY"
C		    1 - "STALA"
C		    3 - "ZMIENNA"
C		    5 - "TABLICA STATYCZNA"
C		    7 - "TYP FORMALNY" / "NAZWA TYPU"/
C		    8 - "REKORD"
C		    9 - "KLASA"
C		   11 - "PROCEDURA"
C		   12 - "FUNKCJA"
C		   13 - "SYGNAL"
C		   14 - "OPERATOR"
C
C     W PRZYPADKU NIEPOPRAWNEGO OPISU ZWRACA UNIWERSALNY.
C.....
      IMPLICIT INTEGER (A-Z)
#include "blank.h"
C
C
CCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER TT(35),TT0(36)
      EQUIVALENCE (TT0(2),TT(1))
      DATA TT0/0,0,8,9,0,9,7,9,8*0,
     X	  3,3,3,1,3,14,13,13,4*0,
     X	  0,10,12,12,11,11,10,13/
C      = RODZAJ ATRYBUTU :
C	  ELEMENTY 0..15 ODPOWIADAJA WARTOSCIOM 0..15 POLA "T"
C	     "    16..27      "        "        5..16 POLA "ZP"
C	     "    28..35      "        "        0..7  POLA "S"
C
C............
      N=IPMEM(IND)
C ... ODCZYTAJ POLE "T" , BITY 12..15
      K=IAND(N,15)
      IF(K.NE.1)GO TO 200
C ... NIE TYP. POLE "ZP" , BITY 8..11
      L=IAND(ISHFT(N,-4),15)
      IF(L.GT.4)GO TO 150
C ... PROCEDURA,FUNKCJA, POLE "S" , BITY 5..7
      L=IAND(ISHFT(N,-8),7)+17
  150 K=L+11
  200 SWHAT=TT(K)
      RETURN
      END
      SUBROUTINE SCALLB
C-----------------------------------------
C
C     WERSJA 1983.04.26
C
C     POCZATEK WYWOLANIA. CZUBEK STOSU ZAWIERA REKORD,KLASE,FUNKCJE,
C     PROCEDURE,BLOK PREF,SYGNAL.
C     JESLI NA STOSIE JEST MODUL BEZ PELNEGO ADR.VIRTUALNEGO
C      /TYLKO ADR.POSREDNI , GDY LASTPR <> 0 / , TO ZASTEPUJE TEN ADRES
C	 PRZEZ PELNY ADR.VIRTUALNY.
C     OTWIERA POLE DANYCH /PO WYZNACZENIU DYNAMICZNEGO PROTOTYPU WRAZ Z
C     OTOCZENIEM/ - O ILE NIE JEST TO PROCEDURA,FUNKCJA STANDARDOWA
C     PRZY BRAKU PARAMETROW FORMALNYCH / WB<>"(" / PRZECHODZI DO ZAKONCZENIA
C      WYWOLANIA /WOLA SCALLE/. UWAGA: DLA FUNKCJI BEZPARAMETROWEJ WOLA
C	SCALLE NAWET DLA WB="(".
C
C     USTAWIA BITY 0-2 SLOWA -3 :
C		 000 =	ZWYKLY,LOKALNY MODUL BEZ PREFIKSU,
C		 001 =	NIELOKALNY LUB PREFIKSOWANY,ALE ZNANE OFFSETY,
C		 010 =	NIEZNANE OFFSETY PARAMETROW /VIRTUAL LUB PARAMETR/
C	    INFORMACJA TA JEST UZYWANA PRZEZ SPARAM,SCALLE .
C
C     WOLANA PRZEZ SDPDA: DLA NAZWY LUB NAZWY PO KROPCE KLASY,REKORDU,
C	   FUNKCJI,PROCEDURY,SYGNALU ORAZ DLA BLOKU PREF.
C     WOLANA PRZEZ SVALUE: GDY NAZWA LUB NAZWA PO KROPCE KLASY,REKORDU,FUNKCJI
C     WYSTAPILA PRZED "," LUB ")" .
C
C     DLA FUNKCJI (NIE-STANDARDOWEJ) GASI FLREADY.
C
C     ##### OUTPUT CODE : 1 , 3 , 4 , 5 , 43 .
C
C
#include "stos.h"
#include "blank.h"
C
      INTEGER ELEM,IND,OPKOD,ADR,PROT,BT
cdsw  DATA SCALBHX1,SCALBHX2 /Z2000, Z4000 /
      data schx1, schx2 / x'2000', x'4000' /
C      RODZAJ ELEMENTU,ADRES PROTOTYPU W IPMEM
C................
      ELEM=STACK(VALTOP)
      IND=STACK(VALTOP-4)
      PROT=IND
C
C..... ROZPOCZNIJ KONTROLE PARAMETROW
      CALL MCALLO(IND,STACK(VALTOP-1),STACK(VALTOP-6),KIND)
cbc moved check for virtual address before check for standard procedure
C     CZY JEST NA STOSIE WYWOLANIE WYMAGAJACE ZABEZPIECZENIA ADR. WIRTUALNEGO
      IF(LASTPR.EQ.0)GO TO 200
C     TAK. WEZ PELNY ADRES VIRTUALNY
      N=TSTEMP(4)
      CALL QUADR3(43,N,STACK(LASTPR-2))
      STACK(LASTPR-2)=N
200   continue
C.....FUNKCJA,PROCEDURA STANDARDOWA ?
      IF(IND.LT.LPMSYS)GO TO 1000
C     NIE.
      FLREADY=.FALSE.
cbc
      LASTPR=VALTOP
      PHADR=TSTEMP(1)
      N=ELEM-7
C     =RODZAJ ELEMENTU, 1..7 ZAMIAST 8..14
      BT=schx1
C     = BITY 0-1 KOPIOWANE DO SLOWA -1 , = ZNANE OFFSETY,NIELOKALNY LUB PREF.
      GO TO (220,260,350,240,240,230),N
C      - OPERATOR TU NIE WYSTAPI
C
C.....REKORD
  220 ADR=TSTEMP(4)
      OPKOD=1
      GO TO 400
C.....SYGNAL
  230 OPKOD=3
      PROT=IPMEM(PROT+1)
C      = NUMER SYGNALU
      GO TO 380
C.....PROCEDURA,FUNKCJA. VIRTUAL LUB PARAMETR ?
  240 IF(KIND.EQ.0)GO TO 260
      BT=schx2
C		CZYLI NIEZNANE OFFSETY
      GO TO 270
C.....KLASA, CD. PROCEDURY,FUNKCJI
C     LOKALNY BEZ PREFIKSU ?
  260 IF(LOCAL.EQ.2 .AND. IPMEM(PROT+21).EQ.0 .AND. STACK(VALTOP-7)
     X .EQ.0) BT=0
  270 IF(KIND.NE.2 .AND. STACK(VALTOP-7).EQ.0)GO TO 350
      OPKOD=5
      GO TO 360
C.....BLOK PREFIKSOWANY
  350 OPKOD=4
  360 PROT=SPRFLD(.FALSE.)
C      = WYZNACZONY DYNAMICZNIE PROTOTYP /BYC MOZE WRAZ Z OTOCZENIEM/
  380 ADR=TSTEMP(1)
C.....WSPOLNE OTWARCIE POLA DANYCH : OPENRC,RAISE,OPEN,SLOPEN
C				 /OPKOD = 1,3,4,5/
  400 CALL QUADR4(OPKOD,ADR,PHADR,PROT)
      STACK(VALTOP-2)=ADR
      STACK(VALTOP-3)=BT
C     OTWARCIE POLA DANYCH   DOSTARCZA AH I ADR.FIZYCZNEGO
C.....CZY SA PARAMETRY AKTUALNE ?
  500 IF(WB.EQ.36)GO TO 550
C     BRAK PAR.AKTUALNYCH, KONCZ WYWOLANIE
  510 CALL SCALLE
      RETURN
C     DLA FUNKCJI BEZPARAMETROWEJ TEZ KONCZ WYWOLANIE
  550 IF(ELEM.EQ.12 .AND. IPMEM(IND+4).EQ.1)GO TO 510
      RETURN
C.....PROCEDURA,FUNKCJA STANDARDOWA
 1000 STACK(VALTOP-2)=0
      STACK(VALTOP-3)=0
C     WYZEROWANE LICZNIKI PAR. INPUT I OUTPUT
      GO TO 500
      END
      SUBROUTINE SCALLE
C-------------------------------------------------------------------------
C
C     WERSJA 1984.04.10
C
C     OBSLUGUJE ZAKONCZENIE WYWOLANIA REKORDU,KLASY,BLOKU PREF.,
C	 PROCEDURY,FUNKCJI,SYGNALU.
C
C     WOLANA : PRZY BRAKU PARAMETROW AKTUALNYCH PRZEZ SCALLB LUB
C	   PO WYSTAPIENIU ")" PRZEZ SDPDA.
C
C     WOLA MCALLC.
C     ZABEZPIECZA STOS.
C     PRZEKAZUJE STEROWANIE.
C     ODCZYTUJE PARAMETRY OUTPUT I WARTOSC FUNKCJI.
C     SPRAWDZA DLA PROCEDURY ISTNIENIE "CALL" I ZJADA. /JESLI BRAK "CALL"
C      - ZASTEPUJE PRZEZ UNIWERSALNY/
C     DLA SYGNALU SPRAWDZA ISTNIENIE "RAISE" I ZJADA /JESLI BRAK "RAISE"
C      - ZASTEPUJE  PRZEZ UNIWERSALNY.
C     REKORD,KLASE ZASTEPUJE PRZEZ WARTOSC / LUB ZDEJMUJE ZE STOSU
C	JESLI WB = ZNACZNIK KONCA INSTRUKCJI LUB ETYKIETA /.
C     FUNKCJE ZASTEPUJE PRZEZ WARTOSC.
C     DLA BLOKU PREF.,PROCEDURY,SYGNALU OBNIZA STOS.
C     DLA FUNKCJI,PROCEDURY,SYGNALU,BLOKU PREF. USUWA POLE DANYCH.
C
C
C     DLA PROCEDURY,FUNKCJI STANDARDOWEJ GENERUJE :
C	PRZEKAZANIE WARTOSCI PARAMETROW INPUT /OPKOD 145/ ,
C	PRZEKAZANIE STEROWANIA /OPKOD 132/ ,
C	ODCZYT PAR. OUTPUT I WARTOSCI FUNKCJI /OPKOD 23/
C	PRZEKAZANIE ODCZYTANYCH WARTOSCI PARAMETROW NA PAR.AKTUALNE
C      ORAZ ZDEJMUJE ZE STOSU PARAMETRY INPUT LEZACE POD FUNKCJA,PROCEDURA.
C      DODATKOWO, FUNKCJE ZASTEPUJE PRZEZ WARTOSC.
C
C
C
C     ##### OUTPUT CODE : 2 , 21 , 54 , 58 , 59 , 132 , 143 , 145 ,
C			     150 , 153 , 159 , 160 , 170 .
C
C     ##### DETECTED ERROR(S) : 450 , 453 .
C
#include "stos.h"
#include "option.h"
#include "blank.h"
C
C
      COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
     * MPROCES, MCOR, MERPF, MBLOCK, MHAND
     *, MNOTVIR
C
C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
C   MASKI I WZORCE:
C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
C    MOTHERS -	    --	   --	   --	   --	  --  INNYCH PROTOTYPOW
C    MPAR -    --    --    --	 --    --    --       ZMIENNYCH I PARAMETROW
C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
C    MASKTP - ZAPRZECZENIE MASKI  MTP
C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
C    MCOR - WZORZEC DLA COROUTINY (7)
C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z	MOTHERS )
C    MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
C    MHAND - WZORZEC DLA HANDLERA
C
CCCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER OPKOD,N,ELEM,CONTRL,IND,ATS,M
      LOGICAL STANDARD
      DATA SCALEHEX / x'1FFF' /
C	ELEM - WSKAZUJE 0-SLOWO OPISU PARAMETRU NA STOSIE
C	CONTRL - INFORMACJA O KONTROLI /MPARIO(..)+1/
C	IND - ADRES W IPMEM OPISU PAR.FORMALNEGO
C	ATS - ATS WARTOSCI PAR.FORMALNEGO LUB WARTOSCI FUNKCJI
C	STANDARD - .TRUE. DLA PROCEDURY,FUNKCJI STANDARDOWEJ
C
C......
      CALL MCALLC
      KIND=0
C.....FUNKCJA,PROCEDURA STANDARDOWA ?
      STANDARD=( STACK(VALTOP-4) .LT. LPMSYS )
      IF(STANDARD)GO TO 2000
C     NIE.
C     JESLI REKORD - PRZESKOCZ
      IF(STACK(VALTOP).EQ.8)GO TO 50
C.....ZABEZPIECZ STOS
      CALL SAFEST
C.....PRZEKAZ STEROWANIE
      CALL SPHADR(VALTOP)
      OPKOD=160
      IF(STACK(VALTOP-3).GT.8191)OPKOD=159
C     GOLOCAL LUB GO
C     PRZEKAZ STEROWANIE Z ADRESEM FIZYCZNYM I AH NOWEGO OBIEKTU
      CALL QUADR3(OPKOD,PHADR,STACK(VALTOP-2))
C
C
C     PO POWROCIE Z GENEROWANEGO OBIEKTU:
C
C
      PHADR=TSTEMP(1)
      ATS=TSTEMP(4)
      STACK(VALTOP-2)=ATS
C     NOWE ATS-Y NA ADR.FIZ. I VIRTUALNY
      CALL QUADR3(2,ATS,PHADR)
C
C
C     CZY PROC. VIRTUALNA LUB FORMALNA? TAK,JESLI BIT 1 =1 W SLOWIE -3
      IF(STACK(VALTOP-3).GE.16384)KIND=1
C      -OBOJETNE: FORMALNA CZY VIRTUALNA /CZY ZNANE OFFSETY/
C
C
C
C.....JESLI SA PARAMETRY OUTPUT-ODCZYTAJ WARTOSCI
   50 M=IAND(STACK(VALTOP-3),SCALEHEX)
C     M=LICZBA PARAMETROW OUTPUT
      IF(M.EQ.0)GO TO 500
C     DLA PROCEDURY STANDARDOWEJ NAJPIERW ODCZYTAJ WARTOSCI WSZYSTKICH
C	PARAMETROW
      IF(.NOT.STANDARD)GO TO 100
      ELEM=FSTOUT-2
      DO 90 N=1,M
C	ODCZYTAJ WARTOSC N-TEGO PAR.OUTPUT PROC.STANDARDOWEJ
C	 I WPISZ ATS TEJ WARTOSCI DO SLOWA -8
	ELEM=ELEM+11
	IND=STACK(ELEM-1)
	NRPAR=STACK(ELEM+1)
   90	STACK(ELEM-8)=SGETPAR(IND,VALTOP)
C
  100 CONTINUE
C
      DO 400 N=1,M
C	OBSLUZ N-TY PARAMETR OUTPUT /OD PRAWEJ DO LEWEJ/
	FSTOUT=FSTOUT+11
	ELEM=FSTOUT-2
	CONTRL=IAND(ISHFT(STACK(ELEM),-4),7)+1
	STACK(ELEM)=IAND(STACK(ELEM),15)
C	ODCZYTANE I WYZEROWANE BITY 9-11
	IND=STACK(ELEM-1)
	NRPAR=STACK(ELEM+1)
	IF(STANDARD)GO TO 102
C	ODCZYTAJ WARTOSC PARAMETRU OUTPUT
	ATS=SGETPAR(IND,VALTOP)
	GO TO 103
  102	ATS=STACK(ELEM-8)
C
C	KONWERSJA LUB DYNAMICZNA KONTROLA
  103	IF(CONTRL.GT.3 .AND.OPTTYP)GO TO 300
C
	IDR=STACK(ELEM-5)
	IF(IDR.EQ.0)GO TO 105
	IDR=STYPFT(ELEM)
C	IDR = TYP FORMALNY PAR.AKT. LUB ZERO
C
  105	GO TO (300,110,120,130,140,150,160),CONTRL
C
C	KONWERSJA DO INTEGER
  110	OPKOD=TSTEMP(1)
	CALL QUADR3(58,OPKOD,ATS)
	ATS=OPKOD
	GO TO 300
C
C	KONWERSJA DO REAL
#if WSIZE == 4
120     opkod = tstemp(1)
#else
120     opkod = tstemp(2)
#endif
	CALL QUADR3(59,OPKOD,ATS)
	ATS=OPKOD
	GO TO 300
C
C	KONTROLA DYN.,OBA TYPY STATYCZNE
  130	CALL QUADR3(150,ATS,STACK(ELEM-4))
	GO TO 300
C
C.....ZNANY OFFSET?
  140	IF(KIND.NE.0)GO TO 165
	OPKOD=TSTEMP(2)
	CALL QUADR4(21,OPKOD,IPMEM(IND-4),IPMEM(IND-3))
	GO TO 200
C	WSTAW TYP STATYCZNY PAR.AKTUALNEGO
  150  IDR=STYPST(ELEM)
C	ZNANY OFFSET?
  160	IF(KIND.EQ.0)GO TO 170
C	NIEZNANY. ODCZYTAJ TYP PAR.FORMALNEGO
  165	OPKOD=SFPRST(NRPAR)
	GO TO 200
C	ZNANY OFFSET
cdsw  170   OPKOD=SPARF2(IND)
cdsw  ----------------------------
 170   opkod = sparft(ind,2)
cdsw  -----------------------------
C
C	OPKOD=ATS ODCZYTANEGO TYPU FORMALNEGO PAR.FORMALNEGO.
  200	CALL QUADR4(170,IDR,ATS,OPKOD)
C	ZAKONCZONA KONTROLA LUB KONWERSJA.
C	PODSTAW WARTOSC PAR.OUTPUT NA PAR.AKTUALNY
  300	CALL SSTORE(ELEM,ATS)
C	ZAKONCZONA OBSLUGA KOLEJNEGO PARAMETRU OUTPUT
C
  400 CONTINUE
C
C
  500 ELEM=STACK(VALTOP)-7
C      = RODZAJ ELEMENTU : 1..6 ZAMIAST 8..13 /OPERATOR TU NIE WYSTAPI/
      GO TO (600,600,800,700,900,650),ELEM
C.....KLASA,REKORD. ZASTAP PRZEZ WARTOSC
  600 STACK(VALTOP)=2
      STACK(VALTOP-3)=0
      STACK(VALTOP-5)=0
cbc kill template after return from process (opcode 222 LKILLTEMP)
      prot = ipmem(stack(valtop-4))
      if (iand(prot, mtp) .eq. mproces)  call quadr1(222)
cbc
C     JESLI NA WEJSCIU JEST POCZATEK INSTRUKCJI LUB ETYKIETA - ZDEJMIJ
C      ZE STOSU
      IF(WB.EQ.32 .OR. WB.EQ.35 .OR. WB.EQ.44)CALL SPOP
      GO TO 1000
C.....SYGNAL. CZY JEST "RAISE" ?
  650 IF(WB.EQ.71)GO TO 670
C     BRAK RAISE - NIELEGALNE WYSTAPIENIE SYGNALU.ZASTAP PRZEZ UNIWERSALNY
      CALL SERROR(453)
      GO TO 720
C     ETYKIETA I USUNIECIE POLA DANYCH HANDLERA
  670 CALL SNEXT
      IDL=153
      GO TO 810
C.....PROCEDURA. CZY JEST CALL?
  700 IF(WB.EQ.7)GO TO 750
C     BRAK CALL - NIELEGALNE WYSTAPIENIE PROCEDURY. ZASTAP PRZEZ UNIWERSALNY
      CALL SERROR(450)
  720 STACK(VALTOP)=0
      GO TO 1000
C
  750 CALL SNEXT
C     PROCEDURA STANDARDOWA ?
      IF(STACK(VALTOP-4).LT.LPMSYS)GO TO 3000
C     NIE.
C.....BLOK PREFIKSOWANY. OBNIZ STOS,USUN POLE DANYCH
  800 IDL=143
  810 CALL QUADR2(IDL,STACK(VALTOP-2))
      CALL SPOP
      GO TO 1000
C.....FUNKCJA. ZASTAP PRZEZ WARTOSC
C     WEZ DLA RESULT: NUMER JAKO PARAMETRU, ADRES OPISU JAKO ATRYBUTU
  900 N=STACK(VALTOP-4)
C     N=ADRES OPISU FUNKCJI W IPMEM
C     PARAMETRY SA NUMEROWANE OD ZERA, RESULT WYSTEPUJE JAKO OSTATNI.
      NRPAR=IPMEM(N+4)-1
      IND=IPMEM(N-5)
      RESULT=SGETPAR(IND,VALTOP)
C      =  ATS ODCZYTANEJ WARTOSCI FUNKCJI
C     FUNKCJA STANDARDOWA ?
      IF(N.LT.LPMSYS)GO TO 4000
C     NIE.
C     WSTAW TYP WARTOSCI
      STACK(VALTOP-3)=IPMEM(N-4)
      STACK(VALTOP-4)=IPMEM(N-3)
C     CZY TYPU FORMALNEGO?
      STACK(VALTOP-5)=0
      IF(IAND(IPMEM(N),4096).EQ.0)GO TO 950
C     A WIEC FUNKCJA TYPU FORMALNEGO. ZWYKLA ?
      IF(KIND.EQ.1) GO TO 930
C     TAK. IDAC PO SL-ACH OD POLA DANYCH ODCZYTAJ TEN TYP
      N=TSTEMP(2)
      CALL QUADR4(54,N,STACK(VALTOP-2),STACK(VALTOP-4))
      GO TO 940
C     FUNKCJA FORMALNA LUB WIRTUALNA TYPU FORMALNEGO. ODCZYTAJ TEN TYP>
  930 N=SFPRST(NRPAR)
  940 STACK(VALTOP-5)=N
C
C     ZASTAP PRZEZ WARTOSC
  950 STACK(VALTOP)=2
C     USUN POLE DANYCH
      CALL QUADR2(143,STACK(VALTOP-2))
      STACK(VALTOP-2)=RESULT
C
C...............WSPOLNE ZAKONCZENIE..............
 1000 PHADR=0
      LASTPR=0
      RETURN
C
C.....FUNKCJA,PROCEDURA STANDARDOWA.
C	  WPISZ WARTOSCI PARAMETROW INPUT.
 2000 OPKOD=STACK(VALTOP-4)
      OPKOD=IPMEM(OPKOD+2)
C     = NUMER FUNKCJI STANDARDOWEJ
C     WYMAGA SPECJALNEGO TRAKTOWANIA ?
      IF(OPKOD.GT.0)GO TO 2100
C     TAK
      CALL SPECIAL
      RETURN
C ... NORMALNIE OBSLUGIWANA
 2100 M=VALTOP-8*STACK(VALTOP-2)
C     = ADRES PIERWSZEGO PAR.INPUT
C     CZY SA / JESZCZE / PARAMETRY INPUT ?
 2200 IF(M.GE.VALTOP)GO TO 2400
C     WPISZ WARTOSC PARAMETRU
      CALL QUADR4(145,SVATS(M),OPKOD,STACK(M-1))
      M=M+8
      GO TO 2200
C
C ... PRZEKAZ STEROWANIE
 2400 CALL QUADR2(132,OPKOD)
      GO TO 50
C
C.....ZAKONCZENIE DLA PROCEDURY STANDARDOWEJ.
C	ZDEJMIJ ZE STOSU WRAZ Z PARAMETRAMI INPUT
 3000 OPKOD=STACK(VALTOP-2)+1
      IF (OPKOD.LT.1)GO TO 3150
      DO 3100 M=1,OPKOD
      CALL SPOP
 3100 CONTINUE
cbc 3150 RETURN
 3150 goto 1000
cbc
C
C.....ZAKONCZENIE DLA FUNKCJI STANDARDOWEJ.
C     ZASTAP FUNKCJE WRAZ Z PARAMETRAMI INPUT PRZEZ WARTOSC
 4000 OPKOD=STACK(VALTOP-2)
      IF (OPKOD.LT.1)GO TO 4150
      DO 4100 M=1,OPKOD
      CALL SPOP
 4100 CONTINUE
 4150 CALL SRESLT1(IPMEM(N-3))
      STACK(VALTOP-3)=IPMEM(N-4)
cbc   RETURN
      goto 1000
cbc
      END
      SUBROUTINE SPECIAL
C----------------------------------------------------------------------------
C
C     OBSLUGUJE WYWOLANIE FUNKCJI STANDARDOWYCH WYMAGAJACYCH
C	SPECJALNEJ OBSLUGI :
C
C     NUMERY :
C	-1   INOT
C	-2   IOR
C	-3   IAND
C	-4   ISHFT
C	-5   ORD
C	-6   CHR
C	-7   XOR
C
C     NA CZUBKU STOSU ZNAJDUJE SIE FUNKCJA,POD NIA ARGUMENTY.
C     PROCEDURA GENERUJE KOD I ZASTEPUJE NA STOSIE FUNKCJE WRAZ
C      Z PARAMETRAMI PRZEZ JEJ WARTOSC.
C
C     ##### OUTPUT CODE : 42 , 53 , 60 , 100 , 101 , 116 , 131 .
C
C
#include "stos.h"
#include "blank.h"
C
C
      INTEGER ARGS(7)
C      = LICZBA ARGUMENTOW
      INTEGER OP(8)
C      = OPKOD DO WYPISANIA
C
      DATA ARGS/1,2,2,2,1,1,2/
      DATA OP/42,100,101,116,60,60,131,53/
C
C
      IND=STACK(VALTOP-4)
C     = ADRES OPISU FUNKCJI
      N=STACK(VALTOP-2)
C     = LICZBA PAR. INPUT NA STOSIE , <= ARGS( .. )
      NR=-IPMEM(IND+2)
C     = NUMER FUNKCJI, 1..7
      IF(ARGS(NR).EQ.2)GO TO 2000
C
C.....JEDNOARGUMENTOWE. JEST ARGUMENT ?
      IF(N.EQ.0)GO TO 1500
      CALL SPOP
C     STALA?
      IF(STACK(VALTOP).EQ.1)GO TO 1700
C     NIE
      RESULT=TSTEMP(1)
      CALL QUADR3(OP(NR),RESULT,STACK(VALTOP-2))
C ... ZASTAP CZUBEK PRZEZ WARTOSC TEJ FUNKCJI
 1500 STACK(VALTOP)=2
 1510 STACK(VALTOP-2)=RESULT
 1520 STACK(VALTOP-1)=0
      STACK(VALTOP-3)=IPMEM(IND-4)
      STACK(VALTOP-4)=IPMEM(IND-3)
      STACK(VALTOP-5)=0
      STACK(VALTOP-6)=0
      RETURN
C ... STALY ARGUMENT
 1700 IF(NR.NE.1)GO TO 1520
      RESULT=NOT(STACK(VALTOP-2))
      GO TO 1510
C
C
C.....DWUARGUMENTOWE. CZY SA OBA ARGUMENTY ?
 2000 TRESLT=IPMEM(IND-3)
      IF(N.EQ.2)GO TO 2200
C     NIE, 1 LUB 0
      IF(N.EQ.1)CALL SPOP
      GO TO 1500
C     O.K.
 2200 CALL SPOP
      CALL SARGMT
      IDL=STACK(VLPREV-2)
      IDR=STACK(VALTOP-2)
C     = ATS-Y PIERWSZEGO I DRUGIEGO ARGUMENTU
      GO TO (2300,2400,2500,2450),ARG
C ... OBA STALE
 2300 GO TO (2320,2320,2330,2340,2301,2301,2370),NR
 2301 CONTINUE
C     IOR
 2320 RESULT=IOR(IDL,IDR)
      GO TO 2350
C     IAND
 2330 RESULT=IAND(IDL,IDR)
      GO TO 2350
C     ISHFT
 2340 RESULT=ISHFT(IDL,IDR)
C
 2350 CALL SRESULT(1)
      RETURN
C     XOR
 2370 RESULT=IEOR(IDL,IDR)
      GO TO 2350
C
C ... LEWY STALY,PRAWY NIE
 2400 IDL=SCONST(IDL)
 2450 RESULT=TSTEMP(1)
      CALL QUADR4(OP(NR),RESULT,IDL,IDR)
 2460 CALL SRESULT(2)
      RETURN
C
C ... PRAWY STALY,LEWY NIE
 2500 IF(NR.EQ.4)GO TO 2600
C     IOR,IAND,XOR
      IDR=SCONST(IDR)
      GO TO 2450
C ... ISHFT( .. , CONST )
 2600 NR=8
cbc   IDR=IAND(IDR,31)
      IF(IDR.NE.0)GO TO 2450
      RESULT=IDL
      GO TO 2460
      END
      INTEGER FUNCTION STYPST(ELEM)
C-----------------------------------------------------------------
C     POMOCNICZA.
C     ZWRACA /NOWY/ ATS TYPU STATYCZNEGO ELEMENTU Z MIEJSCA ELEM  STOSU
C     I WSTAWIA TEN TYP
C
C     ##### OUTPUT CODE : 21 .
C
#include "stos.h"
#include "blank.h"
C
C.....
      STYPST=TSTEMP(2)
      N=STACK(ELEM-3)
      K=STACK(ELEM-4)
      CALL QUADR4(21,STYPST,N,K)
      RETURN
      END
      SUBROUTINE SPHADR(ELEM)
C----------------------------------------------------------------------
C
C     POMOCNICZA.
C     GWARANTUJE,ZE PHADR ZAWIERA ADR.FIZYCZNY GENEROWANEGO OBIEKTU.
C     JESLI PHADR=0,TO ODTWARZA ADR.FIZ. Z ADR.VIRT. ZE SLOWA -2 ELEMENTU
C      ELEM STOSU.
C
C     ##### OUTPUT CODE : 47 .
C
C
#include "stos.h"
#include "blank.h"
C.....
      IF(PHADR.NE.0)RETURN
C     ZATEM TRZEBA ODTWORZYC ADRES FIZYCZNY
      PHADR=TSTEMP(1)
      CALL QUADR3(47,PHADR,STACK(ELEM-2))
C     ODCZYTAJ ADR.FIZYCZNY Z VIRTUALNEGO BEZ MEMBER
      RETURN
      END
C
      integer function sparft(ind, numdsw)
C-----------------------------------------------------------------------------
cdsw  dodatkowy parametr numdsw = 1 - wejscie sparft, = 2 - wejscie sparf2
C
C     ENTRY SPARF2
C
C     POMOCNICZA.
C     DLA WOLANEGO MODULU /ZNANE OFFSETY/ ZWRACA  ATS ZMODYFIKOWANEGO
C     TYPU FORMALNEGO PARAMETRU.
C
C     WEJSCIE SPARF2 : WOLANY MODUL JEST NA CZUBKU STOSU /Z SCALLE/
C     WEJSCIE SPARFT : WOLANY MODUL JEST PONIZEJ CZUBKA /Z SPARAM/
C
C     IND - ADRES OPISU PAR. FORMALNEGO W IPMEM
C
C     ##### OUTPUT CODE : 54 , 85 .
C
#include "stos.h"
#include "blank.h"
C
      LOGICAL MLOCTP
C.....
      ELEM=VLPREV
cdsw  GO TO 1
cdsw  ------------------------
      if(numdsw.eq.1) go to 1
cdsw  ------------------------
C
C-----------------------
cdsw  ENTRY SPARF2(IND)
      ELEM=VALTOP
    1 SPARFT=TSTEMP(2)
C     CZY TEN TYP FORMALNY JEST ATRYBUTEM LOKALNYM?
      L=IPMEM(IND-3)
      IF(MLOCTP(L,STACK(ELEM-4)))GO TO 100
C     NIE.ODCZYTAJ IDAC PO SL-ACH
      CALL QUADR4(54,SPARFT,STACK(ELEM-2),L)
      GO TO 200
C     ATRYBUT LOKALNY
  100 CALL QUADR4(85,SPARFT,PHADR,IND)
C.....ZMODYFIKUJ TYP
  200 CALL SMODIFY(SPARFT,IPMEM(IND-4))
cdsw  SPARF2=SPARFT
      RETURN
      END
      INTEGER FUNCTION SGETPAR(IND,ELEM)
C-------------------------------------------------------------------------
C
C     POMOCNICZA.
C     ODCZYTUJE WARTOSC FUNKCJI LUB PARAMETRU OUTPUT /IND=ADRES OPISU
C      W IPMEM/ I ZWRACA /NOWY/ ATS TEJ WARTOSCI.
C     UZYWANA ROWNIEZ DLA ODCZYTU PAR.OUTPUT LUB WARTOSCI FUNKCJI
C      DLA PROCEDUR,FUNKCJI STANDARDOWYCH.
C     ELEM-MIEJSCE STOSU Z WOLANYM MODULEM
C     UZYWA NRPAR,PHADR.
C
C     ##### OUTPUT CODE : 23 , 52 , 61 , 62 , 63 , 84 , 85 , 86 .
C
#include "stos.h"
#include "blank.h"
C
      INTEGER APET,K
C.....
      APET=SAPET(IPMEM(IND-4),IPMEM(IND-3))

#if WSIZE == 4
cvax  changed because of real appetite = 1
      dswap = apet
      if (dswap .eq. 2) dswap = 1
      sgetpar = tstemp(dswap)
#else
      SGETPAR=TSTEMP(APET)
#endif

      APET=APETYT(APET)
C     STANDARDOWA?
      IF(STACK(ELEM-4).LT.LPMSYS)GO TO 300
C.....NIE
C     CZY ZNANY OFFSET? TAK,JESLI W SLOWIE -3 BIT 1 =0.
      IF(STACK(ELEM-3).GE.16384)GO TO 200
C     ZNANY OFFSET. ODCZYTAJ APET-SLOW
      CALL QUADR4(83+APET,SGETPAR,PHADR,IND)
      RETURN
C     NIEZNANY OFFSET. WEZ ADRES FIZYCZNY PARAMETRU.
  200 K=TSTEMP(1)
      CALL QUADR4(52,K,PHADR,NRPAR)
C     ODCZYTAJ APET-SLOW
      CALL QUADR3(60+APET,SGETPAR,K)
      RETURN
C.....PROCEDURA,FUNKCJA STANDARDOWA
  300 APET=STACK(ELEM-4)
      CALL QUADR4(23,SGETPAR,IPMEM(APET+2),NRPAR)
      RETURN
      END
      INTEGER FUNCTION STYPFT(ELEM)
C-----------------------------------------------------------------------------
C
C     POMOCNICZA.
C     WYLICZA TYP FORMALNY ELEMENTU Z MIEJSCA ELEM STOSU /WARTOSC,ZMIENNA,
C      ELEM.TABLICY,TABL.STATYCZNA,FUNKCJA/ I ZWRACA ATS TEGO TYPU.
C     JESLI WB <> "(" MODYFIKUJE TEN TYP /ZWRACA ZMODYFIKOWANY/
C
C     ##### OUTPUT CODE : 15 , 22 , 54 , 85 .
C
#include "stos.h"
#include "blank.h"
C
      INTEGER N,OPKOD
      LOGICAL MLOCTP
C.....
      N=STACK(ELEM)-1
      GO TO (200,300,200,300,199,199,199,199,199,199,300),N
  199 CONTINUE
C
C.....WARTOSC LUB ELEMENT TABLICY. TYP JUZ JEST WYLICZONY
  200 STYPFT=STACK(ELEM-5)
      GO TO 335
C
C.....ZMIENNA LUB TABLICA STATYCZNA. CZY PRZEZ KROPKE?
  300 IF(STACK(ELEM-7).EQ.0)GO TO 340
C     PRZEZ KROPKE. CZY TYP FORMALNY JEST ATRYBUTEM TEGO POLA?
      IF(STACK(ELEM-5).LE.0)GO TO 310
C     ZATEM TO ATRYBUT LOKALNY.WEZ JEGO ADR.FIZYCZNY
      N=SMEMBER(ELEM)
      OPKOD=85
C     ="ODCZYTAJ 2 SLOWA"
      GO TO 330
C     ODSZUKAJ TYP IDAC PO SL-ACH
  310 N=STACK(ELEM-7)
  320 OPKOD=54
C     ="ODCZYTAJ TYP FORMALNY IDAC PO SL-ACH"
  330 STYPFT=TSTEMP(2)
      CALL QUADR4(OPKOD,STYPFT,N,STACK(ELEM-4))
C
C.....JESLI WB <> "(" ZMODYFIKUJ TYP
  335 IF(WB.NE.36)CALL SMODIFY(STYPFT,STACK(ELEM-3))
      RETURN
C
C     PRZEZ DISPLAY. CZY TYP MOZNA ODCZYTAC PRZEZ DISPLAY?
  340 IF(STACK(ELEM-5).GT.0)GO TO 350
C     ZATEM TRZEBA ISC PO SL-ACH OD MIEJSCA DEKLARACJI ZMIENNEJ
C     SLOWO -5 = - SL TEJ ZMIENNEJ
      N=TSTEMP(4)
      CALL QUADR3(15,N,-STACK(ELEM-5))
C     N = ADR.VIRTUALNY POBRANY Z DISPLAYA
      GO TO 320
C     TYP FORMALNY MOZNA ODCZYTAC POPRZEZ DISPLAY Z WARSTWY= STACK(ELEM-5)
  350 STYPFT=STACK(ELEM-4)
      OPKOD=22
      N=STACK(ELEM-5)
C     CZY TYP JEST ATRYBUTEM LOKALNYM?
      IF(.NOT.MLOCTP(STYPFT,P))GO TO 330
C     TAK
      STYPFT=TSINSE(STYPFT,2)
      GO TO 335
      END
      SUBROUTINE SMODIFY(N,L)
C---------------------------------------------------------------
C
C     POMOCNICZA.
C     N=ATS TYPU FORMALNEGO , L=LICZBA ARRAY OF
C     MODYFIKUJE TEN TYP O WLASCIWA LICZBE ARRAY-OF I ATS WYNIKOWEGO
C     TYPU PODSTAWIA NA N.
C
C     ##### OUTPUT CODE : 87 .
C
      INTEGER TSTEMP
      IF(L.EQ.0)RETURN
C     A WIEC TRZEBA MODYFIKOWAC
      K=TSTEMP(2)
      CALL QUADR4(87,K,N,L)
      N=K
      RETURN
      END
      SUBROUTINE SSTORE(ELEM,ATS)
C-----------------------------------------------------------------------------
C
C     GENERUJE PRZESLANIE WARTOSCI O ADRESIE ATS W TABLICY SYMBOLI NA
C     ELEMENT /ZMIENNA,ELEM.TABLICY,TABL.STATYCZNA/ Z MIEJSCA ELEM STOSU.
C     NIE DOKONUJE ZADNEJ KONTROLI.
C     NIE ZMIENIA STOSU.
C     LICZBA PRZESYLANYCH SLOW ZALEZY OD TYPU WARTOSCI ELEMENTU STOSU
C
C     ##### OUTPUT CODE : 60 , 161 , 162 , 163 , 164 , 165 , 166 .
C
#include "stos.h"
#include "blank.h"
C
      INTEGER APET,ADRES,N
C.....
      N=STACK(ELEM)-2
      ADRES=STACK(ELEM-2)
C     WYLICZ APETYT
      APET=SAPET2(ELEM)
      APET=APETYT(APET)
      GO TO (300,400,500),N
C
C     ZMIENNA. CZY PRZEZ KROPKE?
  300 IF(STACK(ELEM-7).EQ.0)GO TO 350
C     TAK.
      CALL QUADR4(163+APET,SMEMBER(ELEM),ATS,ADRES)
      CALL SCANCEL(ADRES)
      RETURN
C     ZMIENNA PRZEZ DISPLAY.
  350 CALL QUADR3(60,ADRES,ATS)
C      "MOVE"
      RETURN
C
C.....ELEM.TABLICY
C     WPISZ APET-SLOW POD ADRES FIZYCZNY ELEMENTU TABLICY
  400 CALL QUADR3(160+APET,SARRAY(ELEM),ATS)
C
C     TABLICA STATYCZNA
  500 CONTINUE
C     B R A K
      RETURN
      END
      INTEGER FUNCTION SARRAY(ELEM)
C-----------------------------------------------------------------------------
C
C     POMOCNICZA.
C     ZWRACA ATS ADRESU FIZYCZNEGO ELEMENTU TABLICY Z MIEJSCA ELEM STOSU
C     USUWA EWENTUALNY MINUS W SLOWIE -2
C
C     ##### OUTPUT CODE : 64 , 65 , 102 , 103 , 104 , 105 .
C
#include "stos.h"
#include "option.h"
#include "blank.h"
C
      INTEGER N,K
C.....
      SARRAY=TSTEMP(1)
      N=SAPET2(ELEM)
      K=APETYT(N)
      N=STACK(ELEM-7)
C     CZY INDEKS JEST STALA?
      IF(STACK(ELEM-2).LT.0)GO TO 100
C.....NIE.
      IF(K.EQ.1)GO TO 50
C     POMNOZ INDEKS PRZEZ 2 LUB 3
      N=TSTEMP(1)
      CALL QUADR3(62+K,N,STACK(ELEM-7))
   50 CALL QUADR4(102+OPTIND+OPTMEM,SARRAY,STACK(ELEM-2),N)
      RETURN
C.....INDEKS JEST STALA
  100 N=SCONST(K*N)
      STACK(ELEM-2)= - STACK(ELEM-2)
      GO TO 50
      END
      INTEGER FUNCTION SAPET2(ELEM)
C-----------------------------------------------------------------------------
C
C     POMOCNICZA. ZWRACA APETYT /1,3,4/ DLA STALEJ,ZMIENNEJ,WARTOSCI
C     Z MIEJSCA ELEM STOSU.
C
#include "stos.h"
#include "blank.h"
C
      N=STACK(ELEM-3)
      K=STACK(ELEM-4)
      SAPET2=SAPET(N,K)
      RETURN
      END
      INTEGER FUNCTION SAPET(K,N)
C-----------------------------------------------------------------------------
C
C     POMOCNICZA. ZWRACA APETYT/1,2,4/ DLA WARTOSCI TYPU (K,N)
C			 1 - INTEGER,BOOLEAN,STRING,CHAR
C			 2 - REAL
C			 4 - DOWOLNY TYP REFERENCYJNY
C
C
      IMPLICIT INTEGER (A-Z)
#include "blank.h"
C
C
C     TABLICOWY?
      IF(K.GT.0)GO TO 100
C     = 1  ?
      SAPET=1
      IF(N.EQ.NRINT)RETURN
      IF(N.EQ.NRBOOL)RETURN
      IF(N.EQ.NRCHR)RETURN
      IF(N.EQ.NRTEXT)RETURN
C     REAL?
      SAPET=2
      IF(N.EQ.NRRE)RETURN
C     REFERENCYJNY
  100 SAPET=4
      RETURN
      END
      INTEGER FUNCTION SMEMBER(ELEM)
C---------------------------------------------------------------------------
C
C     POMOCNICZA: ZWRACA /NOWY/ ATS ADRESU FIZYCZNEGO Z ADR.VIRT. ELEMENTU
C      Z MIEJSCA ELEM STOSU.
C
C     ##### OUTPUT CODE : 46 , 47  .
C
#include "stos.h"
#include "option.h"
#include "blank.h"
C
C
      SMEMBER=TSTEMP(1)
      N=STACK(ELEM-7)
      CALL QUADR3(46+OPTMEM,SMEMBER,N)
      RETURN
      END
      INTEGER FUNCTION SPRFLD(PARAM)
C----------------------------------------------------------------------------
C
C     ZWRACA /NOWY/ATS NUMERU PROTOTYPU LUB OJCA SYNT. I NUMERU PROTOTYPU.
C     PARAM=.TRUE. -UZYWANE PRZY PRZEKAZYWANIU PARAMETRU AKTUALNEGO
C		/NA CZUBKU NA PEWNO FUNKCJA,PROCEDURA/
C	     DOSTARCZA OJCA SYNTAKTYCZNEGO I PROTOTYPU/SKLEJONE W 1 ARG./
C	     WOLANA PRZEZ SPARAM.
C     PARAM=.FALSE. -UZYWANE PRZY GENEROWANIU OBIEKTU KLASY,PROCEDURY,FUNKCJI
C	     LUB BLOKU PREF. DOSTARCZA NUMERU PROTOTYPU /DLA PARAMETRU LUB
C	     DOSTEPU PRZEZ KROPKE-ROWNIEZ OJCA SYNT./.
C	     CZUBEK STOSU ZAWIERA KLASE,BLOK PREF,PROCEDURE,FUNKCJE.
C	     WOLANA PRZEZ SCALLB.
C
C     NIE UZYWANA DLA PROCEDUR,FUNKCJI STANDARDOWYCH.
C
C     ##### OUTPUT CODE : 15 , 16, 20 , 44 , 45 , 86 , 112 .
C
C
#include "stos.h"
#include "option.h"
#include "blank.h"
CCCCCCCCCCCCCCCC
      LOGICAL PARAM
C
      INTEGER OPKOD,IND,ATS,N
C
C.................
      SPRFLD=TSTEMP(1)
      IND=STACK(VALTOP-4)
C     IND=ADRES PROTOTYPU
C.....CZY TO PARAMETR,VIRTUAL CZY "ZWYKLY" PROTOTYP?
      N=KIND+1
      GO TO (100,200,300),N
C.....ZWYKLY PROTOTYP.WSTAW JEGO NUMER.
  100 CALL QUADR3(16,SPRFLD,STACK(VALTOP-4))
C     DLA BLOKU PREF. TO JUZ WSZYSTKO
      IF(STACK(VALTOP).EQ.10)RETURN
C     CZY PRZEZ KROPKE?
      IF(STACK(VALTOP-7).EQ.0)GO TO 150
C     TAK.
  125 ATS=STACK(VALTOP-7)
C.....SKLEJ ADRES VIRTUALNY /ATS/ I NUMER PROTOTYPU /SPRFLD/ W 1 ARGUMENT.
  130 OPKOD=112
C     OPKOD="SKLEJ W 1 ARG."
      N=SPRFLD
  135 SPRFLD=TSTEMP(3)
      CALL QUADR4(OPKOD,SPRFLD,ATS,N)
      RETURN
C.....ZWYKLY PROTOTYP NIE PRZEZ KROPKE.JESLI NIE PARAMETR-KONIEC.
  150 IF(.NOT.PARAM)RETURN
C     ZATEM PARAMETR.WEZ ADRES Z DISPLAYA.
      ATS=TSTEMP(4)
      CALL QUADR3(15,ATS,IPMEM(IND-1))
      GO TO 130
C.....PROCEDURA,FUNKCJA VIRTUALNA.
  200 IF(STACK(VALTOP-7).EQ.0)GO TO 250
C     WYZNACZ PRZEZ KROPKE PROTOTYP VIRTUALA
cbc split opcode 44,45 into 228 (LASKPROT) and 44,45 (LVIRTDOT)
cbc in order to call virtual from process properly 
cbc   CALL QUADR4(44+OPTMEM,SPRFLD,STACK(VALTOP-7),IPMEM(IND+27))
      call quadr2(228, stack(valtop-7))
      call quadr3(44+optmem, sprfld, ipmem(ind+27))
cbc
      GO TO 125
C     WYZNACZ PRZEZ DISPLAY PROTOTYP VIRTUALA
  250 CALL QUADR4(20,SPRFLD,IPMEM(IND-1),IPMEM(IND+27))
      GO TO 150
C.....PARAMETR. ODCZYTAJ
  300 IF(STACK(VALTOP-7).EQ.0)GO TO 350
C     A WIEC PRZEZ KROPKE.WEZ ADRES FIZYCZNY POLA.
      ATS=SMEMBER(VALTOP)
      N=IND
      OPKOD=86
C     OPKOD="WCZYTAJ 3 SLOWA Z POLA O ADR.FIZYCZNYM..."
C     ATS=ADR.FIZYCZNY,SPRFLD=ATS PARAMETRU
      GO TO 135
C     PARAMETR PRZEZ DISPLAY
  350 SPRFLD=TSINSE(IND,LOCAL)
      RETURN
      END
      INTEGER FUNCTION SFPRST(N)
C----------------------------------------------------
C
C     POMOCNICZA. N=NUMER PARAMETRU. ODCZYTUJE TYP
C     /NIEZNANY W CZASIE KOMPILACJI/ N-TEGO PARAMETRU
C     PROCEDURY,FUNKCJI VIRTUALNEJ LUB FORMALNEJ,ZWRACA JEGO ATS.
C
C     ##### OUTPUT CODE : 40 .
C
#include "stos.h"
C
C
C
      SFPRST=TSTEMP(2)
      CALL QUADR4(40,SFPRST,PHADR,N)
      RETURN
      END
      INTEGER FUNCTION SPARST(N)
C-----------------------------------------------------------------------
C
C     POMOCNICZA.WSTAWIA TYP STATYCZNY PARAMETRU FORMALNEGO.
C     N=ADRES OPISU PARAMETRU W IPMEM
C
C     ##### OUTPUT CODE : 21 .
C
      IMPLICIT INTEGER (A-Z)
#include "blank.h"
C
C
      SPARST=TSTEMP(2)
      CALL QUADR4(21,SPARST,IPMEM(N-4),IPMEM(N-3))
      RETURN
      END
      SUBROUTINE SAFE(N)
C---------------------------------------------------------------------
C
C     N = ADRES W TABLICY SYMBOLI LUB 0.
C     JESLI N <> 0 ,GENERUJE NOWY ATRYBUT ROBOCZY I ZASTEPUJE NIM
C      PARAMETR AKTUALNY,ZACHOWUJAC ZNAK.
C     GENERUJE OPKOD MOVE&SAFE - NOWY ATRYBUT Z WARTOSCIA I APETYTEM
C     STAREGO,WARTOSC W ZMIENNEJ ROBOCZEJ.
C
C     ##### OUTPUT CODE : 195 .
C
#include "stos.h"
#include "blank.h"
C
C
      IF(N.EQ.0)RETURN
      LSTEMP=LSTEMP-3
      K=LSTEMP
C     ABY ZACHOWAC EWENTUALNY MINUS
      IF(N.GT.0) GO TO 100
      K= - K
      N= - N
  100 CALL QUADR3(195,LSTEMP,N)
      N=K
      RETURN
      END
      INTEGER FUNCTION TSTEMP(N)
C------------------------------------------------------------------------
C
C
C     ##### OUTPUT CODE : 201 , 202 , 203 , 204 .
C
#include "stos.h"
#include "blank.h"
C
C
      LSTEMP=LSTEMP-3
      TSTEMP=LSTEMP
      CALL QUADR2(200+N,TSTEMP)
      IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
      RETURN
      END
      INTEGER FUNCTION TSINSE(K,N)
C-------------------------------------------------------------------------
C
C     K = ADRES OPISU ATRYBUTU W IPMEM
C     N = WIDZIALNOSC : 0 - GLOBALNY,1 - PRZEZ DISPLAY,2 - LOKALNY ATRYBUT
C
C     WYZNACZA ADRES OPISU ATRYBUTU W TABLICY SYMBOLI.
C     UZYWA POMOCNICZEGO SLOWNIKA ZAWIERAJACEGO TYLKO ATRYBUTY UZYTE
C     W BIEZACYM MODULE.
C
C     ELEMENTY SLOWNIKA:
C	      SLOWO  0 = P /BIEZACY PROTOTYP/	 ORAZ
C	      SLOWO +1 = ADRES OPISU ATRYBUTU W IPMEM
C			  <=> ATRYBUT JEST W SLOWNIKU.
C					    - I WTEDY SLOWO +1 OPISU
C			     ATRYBUTU ZAWIERA ADRES TEGO ELEMENTU SLOWNIKA
C
C	      SLOWO +2 = ADRES W TABLICY SYMBOLI
C
C	      JESLI SLOWO 0  <> P LUB SLOWO +1	<> ADRESU ATRYBUTU
C		 TO ATRYBUTU JESZCZE NIE MA W SLOWNIKU
C     ELEMENTY SLOWNIKA DOPISYWANE SA NA LEWO OD LMEM
C	IPMEM(LMEM) = INDEKS PIERWSZEGO OD PRAWEJ WOLNEGO
C
C
C
C     ##### OUTPUT CODE : 205 , 206 , 207 .
C
C     ##### DETECTED ERROR(S) : 553 , 554 . ( PRZEPELNIENIA )
C
C
#include "stos.h"
#include "blank.h"
C
C
C
C
      TSINSE=IPMEM(K+1)
C     UZYTY JUZ W TYM MODULE?
      IF(IPMEM(TSINSE).NE.P)GO TO 100
      IF(IPMEM(TSINSE+1).NE.K)GO TO 100
C.....TAK.
      TSINSE=IPMEM(TSINSE+2)
      RETURN
C.....JESZCZE NIE. WYZNACZ NOWY ADRES W TABLICY SYMBOLI
  100 J=IPMEM(LMEM)-3
      IF(IRECN.GT.J)GO TO 200
      IPMEM(LMEM)=J
      TSINSE=J+1
      IPMEM(TSINSE)=P
      IPMEM(TSINSE+1)=K
      IPMEM(TSINSE+2)=FRSTTS
      IPMEM(K+1)=TSINSE
      TSINSE=FRSTTS
      FRSTTS=FRSTTS+3
      CALL QUADR3(205+N,TSINSE,K)
      IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
      RETURN
C.....PRZEPELNIENIE TABLICY SYMBOLI LUB SLOWNIKA STALYCH REAL
  200 CALL SERRO2(504,0)
      RETURN
      END
      SUBROUTINE SCANCEL(ADR)
C-----------------------------------------------------------------------------
C
C     JESLI ATRYBUT WSKAZANY PRZEZ ADR BYL UZYTY /JEST W TABLICY
C	SYMBOLI/  - PROCEDURA WYPISUJE OPKOD "CANCEL"  , INACZEJ
C      NIC NIE ROBI.
C
C     UZYWANA PRZY ZMIANIE WARTOSCI ATRYBUTU DOSTEPNEGO PRZEZ KROPKE,
C      DLA ZABEZPIECZENIA NASTEPNEGO PRZEBIEGU PRZED TRZYMANIEM
C	INFORMACJI "WARTOSC ATRYBUTU W REJESTRZE" POMIMO /NIEJAWNEJ/
C	ZMIANY WARTOSCI TEGO ATRYBUTU PRZY UZYCIU DOSTEPU KROPKOWANEGO.
C
C     ##### OUTPUT CODE : 158 .
C
C
      IMPLICIT INTEGER (A-Z)
#include "blank.h"
C
C
C
C.....JEST W TABLICY SYMBOLI?
      N=IPMEM(ADR+1)
      IF(IPMEM(N).NE.P)RETURN
      IF(IPMEM(N+1).NE.ADR)RETURN
C     TAK
      CALL QUADR2(158,IPMEM(N+2))
      RETURN
      END
      SUBROUTINE SAFEST
C-------------------------------------------------------------------------
C
C     ZABEZPIECZA ELEMENTY STOSU PRZY GENERACJI NOWEGO MODULU:
C     DLA ELEMENTOW BEDACYCH LSE ZABEZPIECZA ADRES TJ. WARTOSC WYRAZENIA
C     PRZED KROPKA DLA ZMIENNEJ I TABLICY STATYCZNEJ, ADRES TABLICY DLA
C     ELEMENTU TABLICY I WARTOSC INDEKSU - JESLI NIE STALA - DLA TABLIC.
C
C     DLA ELEMENTOW POWYZEJ LSTLSE ZABEZPIECZA WARTOSC ZMIENNYCH.
C
C     ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
C
#include "stos.h"
#include "blank.h"
C
C
      INTEGER K,ELEM,N,L
C......ZACZNIJ OD POPRZEDNIEGO
      K=VLPREV
C     CZY JEST COS NIEZABEZPIECZONEGO NAD OPISAMI PETLI FOR?
  100 IF(K.GT.LSTFOR .AND. K.GT.LSTSAF)GO TO 120
C     NIE
      LSTSAF=VLPREV
      RETURN
C     TAK.
  120 ELEM=STACK(K)
C     ELEM=RODZAJ ELEMENTU
      IF(ELEM.LT.2 .OR. ELEM.GT.5)GO TO 1000
C     LSE?
      IF(K.LE.LSTLSE)GO TO 200
C.....A WIEC POWYZEJ LSE : WARTOSC,ZMIENNA,ELEM.TABLICY,TABLICA STATYCZNA.
C     ZASTAP PRZEZ WARTOSC.
      IF(ELEM.EQ.2)GO TO 150
      IF(ELEM.EQ.4)GO TO 160
C     B R A K	DLA TABLICY STATYCZNEJ
C ... ZMIENNA. PRZEZ KROPKE?
      IF(STACK(K-7).EQ.0)GO TO 140
C     TAK.ODCZYTAJ WARTOSC
      N=SAPET2(K)
C     N=RODZAJ APETYTU ZMIENNEJ
#if WSIZE == 4
cvax changed because of real appetite = 1
      dswap = n
      if (dswap .eq.2) dswap = 1
      l = tstemp(dswap)
#else
      L=TSTEMP(N)
#endif

      N=APETYT(N)
      CALL QUADR4(83+N,L,SMEMBER(K),STACK(K-2))
  135 STACK(K-2)=L
C     WPISZ 'WARTOSC'
  140 STACK(K)=2
  150 CALL SAFE(STACK(K-2))
      GO TO 1000
C ... ELEM.TABLICY.  ODCZYTAJ WARTOSC
  160 N=SAPET2(K)
#if WSIZE == 4
cvax changed because of real appetite = 1
      dswap = n
      if (dswap .eq.2) dswap = 1
      l = tstemp(dswap)
#else
      L=TSTEMP(N)
#endif

      N=APETYT(N)
      CALL QUADR3(60+N,L,SARRAY(K))
      GO TO 135
C.....LSE : ZMIENNA,ELEM.TABLICY,TABLICA STATYCZNA.
  200 CALL SAVEVAR(K)
C
C.....WEZ POPRZEDNI ELEMENT
 1000 K=K-STCKAP(ELEM)
      GO TO 100
      END
      SUBROUTINE SINDXS
C      MAKIETA
      RETURN
      END
      SUBROUTINE QUADR4(N1,N2,N3,N4)
C------------------------------------------------------------
C
C     WYPISUJE GENEROWANY KOD POSREDNI
C
#include "stos.h"
#include "blank.h"
C
C
      COMMON/TEST/TESTC,TESTS,TESTH
      LOGICAL TESTC,TESTS,TESTH
      common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
C
C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1

      IPMEM(LSTWRD+1)=N1
      IPMEM(LSTWRD+2)=N2
      IPMEM(LSTWRD+3)=N3
      IPMEM(LSTWRD+4)=N4

      IF(.NOT.TESTC) GOTO 1000
      call ffputcs(13,' *******************')
      call ffputi (13,N1,8)
      call ffputi (13,N2,8)
      call ffputi (13,N3,8)
      call ffputi (13,N4,8)
      call ffputnl(13)
1000  CONTINUE

      LSTWRD=LSTWRD+4
      IF(LSTWRD.GE.LMEM-4)CALL QDROUT
      RETURN
      END
      SUBROUTINE QUADR3(N1,N2,N3)
C------------------------------------------------------------
C
C     WYPISUJE GENEROWANY KOD POSREDNI
C
C
#include "stos.h"
#include "blank.h"
C
      COMMON/TEST/TESTC,TESTS,TESTH
      LOGICAL TESTC,TESTS,TESTH
      common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
C
C
C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
      IPMEM(LSTWRD+1)=N1
      IPMEM(LSTWRD+2)=N2
      IPMEM(LSTWRD+3)=N3

      IF(.NOT.TESTC) GOTO 1000
      call ffputcs(13,' *******************')
      call ffputi (13,N1,8)
      call ffputi (13,N2,8)
      call ffputi (13,N3,8)
      call ffputnl(13)
1000  CONTINUE

      LSTWRD=LSTWRD+3
      IF(LSTWRD.GE.LMEM-4)CALL QDROUT
      RETURN
      END
      SUBROUTINE QUADR2(N1,N2)
C------------------------------------------------------------
C
C     WYPISUJE GENEROWANY KOD POSREDNI
C
#include "stos.h"
#include "blank.h"
C
C
      COMMON/TEST/TESTC,TESTS,TESTH
      LOGICAL TESTC,TESTS,TESTH
      common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
C
C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
      IPMEM(LSTWRD+1)=N1
      IPMEM(LSTWRD+2)=N2

      IF(.NOT.TESTC) GOTO 1000
      call ffputcs(13,' *******************')
      call ffputi (13,N1,8)
      call ffputi (13,N2,8)
      call ffputnl(13)
1000  CONTINUE

      LSTWRD=LSTWRD+2
      IF(LSTWRD.GE.LMEM-4)CALL QDROUT
      RETURN
      END
      SUBROUTINE QUADR1(N1)
C------------------------------------------------------------
C
C     WYPISUJE GENEROWANY KOD POSREDNI
C
#include "stos.h"
#include "blank.h"
C
C
      COMMON/TEST/TESTC,TESTS,TESTH
      LOGICAL TESTC,TESTS,TESTH
      common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
C
C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
      LSTWRD=LSTWRD+1
      IPMEM(LSTWRD)=N1

      IF(.NOT.TESTC) GOTO 1000
      call ffputcs(13,' *******************')
      call ffputi (13,N1,8)
      call ffputnl(13)
1000  CONTINUE

      IF(LSTWRD.GE.LMEM-4)CALL QDROUT
      RETURN
      END
      SUBROUTINE QDROUT
C-----------------------------------------------------------------------------
C
C     OPROZNIA BUFOR IPMEM Z GENEROWANYM KODEM POSREDNIM.
C     PRZEPISUJE OSTATNIE 3 LICZBY NA POCZATEK,USTAWIA LSTWRD.
C     JESLI ERRFLG=.TRUE. - NIE WYPISUJE NIC.
C
#include "stos.h"
#include "blank.h"
C
C
C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
      COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
      LOGICAL ERRFLG
C
C.....
      IF(ERRFLG)GO TO 100
C     WEZ NOWY NUMER REKORDU
      call ffwrite_ints(18, ipmem(lmem-259), 256)

cbc
cdsw *********************************       
C     PRZEPISZ OSTATNIE 3 SLOWA NA POCZATEK
      N=LMEM-259
      M=LMEM-3
      IPMEM(N)=IPMEM(M)
      IPMEM(N+1)=IPMEM(M+1)
      IPMEM(N+2)=IPMEM(M+2)
  100 LSTWRD=LSTWRD-256
      RETURN
      END
      SUBROUTINE SERROR(NUMER)
C------------------------------------------------------------------------
cdsw procedura podzielona na serror i serro2
C
C     SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
C     DLA 'UNIWERSALNEGO' NIE ROBI NIC.
C
C
C     ENTRY SERRO2
C
C
#include "stos.h"
#include "blank.h"
C
C
      COMMON/TEST/TESTC,TESTS,TESTH
      LOGICAL TESTC,TESTS,TESTH
C
C
      ELEM=VALTOP
  100 IF(STACK(ELEM).EQ.0)RETURN
      NAZWA=STACK(ELEM-1)

      IF(.NOT.TESTC) GOTO 1000
      call ffputcs(13,' ERROR')
      call ffputi (13,NUMER,6)
      call ffputi (13,NAZWA,8)
      call ffputnl(13)
1000  CONTINUE

      CALL MERR(NUMER,NAZWA)
      RETURN
      END
      SUBROUTINE SERRO2(NUMER,elem)
C------------------------------------------------------------------------
cdsw procedura podzielona na serror i serro2
C
C     SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
C     DLA 'UNIWERSALNEGO' NIE ROBI NIC.
C
C
C     ENTRY SERRO2
C
C
#include "stos.h"
#include "blank.h"
C
C
      COMMON/TEST/TESTC,TESTS,TESTH
      LOGICAL TESTC,TESTS,TESTH
C
C
  100 IF(STACK(ELEM).EQ.0)RETURN
      NAZWA=STACK(ELEM-1)

      IF(.NOT.TESTC) GOTO 1000
      call ffputcs(13,' ERROR')
      call ffputi (13,NUMER,6)
      call ffputi (13,NAZWA,8)
      call ffputnl(13)
1000  CONTINUE

      CALL MERR(NUMER,NAZWA)
      RETURN
      END
      SUBROUTINE SSTOVF
C---------------------------------------------------------------------------
C
C     SYGNALIZUJE PRZEPELNIENIE TABLICY SYMBOLI - BLAD 553
C      I CZYSCI JA
C
C
#include "stos.h"
#include "blank.h"
cdsw&bc
      common /stacks/ btsins, btstem
C
C
C
C
C....PRZEPELNIENIE TABLICY SYMBOLI
      CALL MERR(553,0)
C     OPROZNIJ TABLICE SYMBOLI
cdsw&bc      FRSTTS=LPMEM+1
c            TEMPNR=LMEM-3
      frstts = btsins
      tempnr = btstem-3
c
cdsw  ----------  added  -----------
      lstemp = tempnr
cdsw  ------------------------------
      IPMEM(LMEM)=BOTTOM-1
      RETURN
      END


      SUBROUTINE STEST
C---------------------------------------------------------------------
C
C     READ TESTING OPTIONS
#include "stos.h"
C
C
      COMMON/TEST/TESTC,TESTS,TESTH
      LOGICAL TESTC,TESTS,TESTH
C
cdsw  BYTE  CHARS(80)
cdsw  BYTE  HN,HNS,HY,HYS,HC,HS,HH
cdsw  ---------------------------------
      character chars(80)
      character hn,hns,hy,hys,hc,hs,hh
cdsw  ---------------------------------
      DATA HN,HNS,HY,HYS,HC,HS,HH /'n','n','y','y','c','s','h'/
C
C
      TEST=.FALSE.
      TESTC=.FALSE.
      TESTS=.FALSE.
      TESTH=.FALSE.
      ATLINE=0
      RETURN

100   call ffputcs(0,' TESTING ?   Y/N:')
      call ffgets (0,CHARS,80)

      IF(CHARS(1).EQ.HN .OR. CHARS(1).EQ.HNS)RETURN
      IF(CHARS(1).NE.HY .AND. CHARS(1).NE.HYS) GO TO 100
      TEST=.TRUE.

      call ffputcs(0,' OPTIONS : C - code , S - stack , H - halt')
      call ffputnl(0)

      call ffgets (0,CHARS,80)

      DO 200 N=1,80
      IF(CHARS(N).EQ.HC)TESTC=.TRUE.
      IF(CHARS(N).EQ.HS)TESTS=.TRUE.
      IF(CHARS(N).EQ.HH)TESTH=.TRUE.
  200 CONTINUE
cdsw  IF(TESTH) CALL STOPAT
      RETURN
      END
      SUBROUTINE SABORT
      RETURN
      END
      SUBROUTINE SRCVOFF
      RETURN
      END


      SUBROUTINE SLCSTOUT
C---------------------------------------------------------------------
C
C     WYPISUJE NA PLIK 15 HEKSADECYMALNA REPREZENTACJE
C     TABLICY SYMBOLI I L-KODU.
C
#include "stos.h"
#include "blank.h"
C
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
      INTEGER BL(302)
      EQUIVALENCE ( BL(1),IOP(1) )

      integer*4 offset
      integer*2 bigbuf
      integer buf1(1)
      common /combuf/ ind, length, bigbuf(16000)
cvax  equivalence (bigbuf(1), buf1(1))
      character bufc(32000)
      equivalence (bigbuf(1), buf1(1), bufc(1))

cdsw&ail
      common /stacks/ btsins, btstem

cbc
C
C.....SYMBOL TABLE
cdsw&ail
c  adres stalej none jest przekazany na zmiennej LOCAL ( numer 300 )     
      LOCAL = btstem-3
      call ffwrite_ints(15, bl(1), 302)
#if WSIZE == 4
CPS   tu bylo porownanie z 50000, co dla LPMEM=48000 dalo maximun
CPS   2000 slow na stale rzeczywiste - nie rozumiem skad to ograniczenie
CPS   dlatego nie zmienilem go
      if (irecn .gt. LPMEMSIZE+2000 ) call mdrop(0)
#endif
      call ffwrite_ints(15, ipmem(1), irecn)
C.....L-CODE
      offset=0
      call ffseek(18,offset)
3000  len=31744
      call ffread(18,buf1(1),len)
      if (len .eq. 0) goto 3010
      wlen = len
      call ffwrite(15,buf1(1),wlen)
      if (len .eq. 31744) goto 3000
3010  continue
      RETURN
      END