sources/pass1/al12.ff

   1 C    Loglan82 Compiler&Interpreter
   2 C     Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3 C     Copyright (C)  1993, 1994 LITA, Pau
   4 C
   5 C     This program is free software; you can redistribute it and/or modify
   6 C     it under the terms of the GNU General Public License as published by
   7 C     the Free Software Foundation; either version 2 of the License, or
   8 C     (at your option) any later version.
   9 C
  10 C     This program is distributed in the hope that it will be useful,
  11 C     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 C     GNU General Public License for more details. File: LICENSE.GNU
  14 C  ===============================================================
  15
  16       SUBROUTINE SPARAM
  17 C-----------------------------------------------------------------------------
  18 C
  19 C     WERSJA 1982.09.16
  20 C
  21 C     OBSLUGUJE TRANSMISJE I KONTROLE PARAMETRU AKTUALNEGO.
  22 C     NA CZUBKU STOSU JEST PARAMETR AKTUALNY, PONIZEJ WOLANA FUNKCJA,
  23 C      PROCEDURA,KLASA,REKORD,BLOK PREFIKSOWANY.
  24 C     PO OBSLUZENIU PARAMETRU ZDEJMUJE GO ZE STOSU.
  25 C     NIE WOLA SNEXT.
  26 C
  27 C     UZYWANA ROWNIEZ DLA PROCEDUR I FUNKCJI STANDARDOWYCH.
  28 C          / TYLKO PARAMETRY INPUT, OUTPUT, IN-OUT / .
  29 C
  30 C
  31 C     KOLEJNOSC OBSLUGI PARAMETRU :
  32 C        1) WOLA MPKIND OKRESLAJACE RODZAJ PARAMETRU :
  33 C              0 - UNIWERSALNY
  34 C              1 - INPUT
  35 C              2 - OUTPUT
  36 C              3 - TYPE
  37 C              4 - FUNKCJA
  38 C              5 - PROCEDURA
  39 C              6 - IN-OUT
  40 C          I PRZYPISUJE PARAM ADRES OPISU PAR.FORMALNEGO W IPMEM
  41 C
  42 C        2) JESLI PAR.FORMALNY JEST UNIWERSALNY LUB PAR.AKTUALNY JEST
  43 C           UNIWERSALNY LUB NIEWLASCIWEGO RODZAJU, A PAR.FORM. <> "TYPE"  -
  44 C             NIE ROBI NIC    /POZA SYGNALIZACJA BLEDU/
  45 C
  46 C        3) DLA PAR. INPUT : WOLA MPARIO /BADA ZGODNOSC TYPOW/ ,GENERUJE KOD
  47 C             EWENT. KONWERSJI LUB KONTROLI DYNAMICZNEJ I WPISUJE WARTOSC PAR.
  48 C             AKTUALNEGO DO GENEROWANEGO POLA DANYCH /DLA STALYCH REPREZENTO-
  49 C              WANYCH PRZEZ ZERA NIE WPISUJE NICZEGO/.
  50 C               DLA PROCEDURY,FUNKCJI STANDARDOWEJ NIE WPISUJE WARTOSCI
  51 C                PARAMETRU, LECZ ZAMIENIA NA STOSIE PARAMETR I PROCEDURE
  52 C                /FUNKCJE/ MIEJSCAMI, DZIEKI CZEMU PROCEDURA JEST NA STOSIE
  53 C                NAD WSZYTKIMI JUZ PRZETWORZONYMI PARAMETRAMI INPUT.
  54 C
  55 C
  56 C           DLA PAR. OUTPUT : WOLA MPARIO,ZABEZPIECZA ADRES ZMIENNEJ /ADR.
  57 C               TABLICY I INDEKS,ADR. PRZED KROPKA/ I TYP FORMALNY,WPISUJE
  58 C               OPIS PARAMETRU NA STOS I ZWIEKSZA LICZNIK PARAMETROW OUTPUT
  59 C               /JESLI BRAK MIEJSCA NA OPIS - NIE ZWIEKSZA/
  60 C
  61 C           DLA PAR. TYPE : WOLA MPARTP / ZAWSZE! ,DLA PAR.AKT. NIEPOPRAWNEGO
  62 C               LUB UNIWERSALNEGO PODAJE NRUNIV/ I WPISUJE TYP DO POLA DANYCH
  63 C
  64 C           DLA PAR. FUNCTION,PROCEDURE : WOLA MPARPF ,
  65 C                   USTAWIA KIND , WOLA SPRFLD /GENERUJACA PROTOTYP
  66 C                 WRAZ Z OTOCZENIEM/
  67 C            WPISUJE PROTOTYP I OTOCZENIE PAR.AKTUALNEGO DO POLA DANYCH,
  68 C              EW. GENERUJE DYNAMICZNA  KONTROLE ZGODNOSCI NAGLOWKOW.
  69 C
  70 C           DLA PAR. IN-OUT : NAJPIERW OBSLUGUJE GO JAK PAR. OUTPUT,
  71 C                      A NASTEPNIE JAK PAR.INPUT
  72 C
  73 C     UZYWA: PHADR , NRPAR
  74 C
  75 C
  76 C     # OUTPUT CODE : 43 , 52 , 144 , 150 , 161 , 162 , 163 ,
  77 C                        164 , 165 , 166 , 170 .
  78 C
  79 C     ##### DETECTED ERROR(S) : 470 , 471 , 472 , 473 , 474 , 478 , 550 .
  80 C
  81 C
  82 #include "stos.h"
  83 #include "option.h"
  84 #include "blank.h"
  85 CCCCCCCCCCCCCCCCCCCCCC
  86       INTEGER PARAM,APET,CONTRL,ATS,LNRPAR,PARKIND,ELEM
  87 C     PARAM = ADRES W IPMEM OPISU PARAMETRU FORMALNEGO
  88 C     APET = LICZBA SLOW NA PARAMETR FORMALNY
  89 C     CONTRL = INFORMACJA O KONWERSJI LUB KONTROLI DYNAMICZNEJ
  90 C     ATS = ATS WARTOSCI PAR. LUB ADR.FIZYCZNY DLA NIEZNANEGO OFFSETU
  91 C     PARKIND = RODZAJ PAR.FORMALNEGO, 1..7 ,=MPKIND( )+1
  92 C     ELEM = RODZAJ ELEMNTU Z CZUBKA STOSU
  93 C
  94       LOGICAL DCONTR
  95       DATA SPARAHEX /x'0800'/
  96 C     =.TRUE. JESLI KONIECZNA DYNAMICZNA KONTROLA NAGLOWKOW PROC.,FUNC.
  97 C
  98 C...............
  99       DCONTR=.FALSE.
 100 C     RODZAJ PAR.AKTUALNEGO ?
 101       ELEM=STACK(VALTOP)
 102 C     RODZAJ PAR.FORMALNEGO ?
 103       PARKIND=MPKIND(PARAM)+1
 104 C     JESLI PAR.AKTUALNY UNIWERSALNY-POMIN
 105       IF(ELEM.EQ.0.AND. PARKIND.NE.4)GO TO 9905
 106       GO TO(9905,1000,2000,3000,4000,4000,2000),PARKIND
 107 C
 108 C
 109 C
 110 C- - - - - - - - - - PAR. I N - O U T - - - - - - -
 111 C
 112 C     ZMIEN KWALIFIKACJE NA INPUT /KOD ODCZYTUJACY WARTOSC JUZ WYGENEROWANY/
 113 C
 114   990 PARKIND=2
 115 C
 116 C
 117 C-------------------- PAR. I N P U T ------------
 118 C     CZY POPRAWNY PAR. AKTUALNY?
 119  1000 IF(ELEM.LT.6 .OR. ELEM.EQ.12)GO TO 1003
 120 C     NIEPOPRAWNY PAR. AKTUALNY
 121       PARAM=470
 122       GO TO 9600
 123  1003 LNRPAR=NRPAR
 124 C     PRZECHOWAJ NUMER PARAMETRU: NA CZUBKU MOZE BYC FUNKCJA BEZPARAMETROWA,
 125 C     ODCZYT JEJ WARTOSCI MOZE ZNISZCZYC NRPAR
 126       CALL SVALUE
 127       NRPAR=LNRPAR
 128 C     SPRAWDZ ZGODNOSC TYPOW
 129       CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
 130      X STACK(VALTOP-6))
 131       APET=SAPET(IPMEM(PARAM-4),IPMEM(PARAM-3))
 132       IF(CONTRL.EQ.1)CALL SVINT(VALTOP)
 133       IF(CONTRL.EQ.2)CALL SVREAL(VALTOP)
 134       ATS=STACK(VALTOP-2)
 135 C     ATS WARTOSCI PARAMETRU
 136 C.....FUNKCJA,PROCEDURA STANDARDOWA ?
 137       IF(STACK(VLPREV-4).LT.LPMSYS)GO TO 1800
 138 C     NIE.
 139       CALL SPHADR(VLPREV)
 140 C     CZY PAR.AKTUALNY JEST STALA?
 141       IF(ELEM.EQ.1)GO TO (1007,1008,9905,9905),APET
 142 C
 143 C     PARAMETR NIE JEST STALA
 144       APET=APETYT(APET)
 145       GO TO 1050
 146 C
 147 C
 148 C.....PAR.AKTUALNY JEST STALA. JESLI REPREZENTOWANA PRZEZ ZERA - NIC NIE
 149 C       ROB /INICJALIZACJA POLA WPISALA ZERA/
 150 C ... APETYT 1 ( INTEGER,BOOLEAN,CHAR,STRING )
 151  1007 IF(ATS.EQ.0)GO TO 9905
 152 C     WSTAW STALA INTEGER,SKOCZ DO WPISANIA WARTOSCI PARAMETRU
 153       ATS=SCONST(ATS)
 154       GO TO 9750
 155 C ... APETYT 2 ( REAL - TYP FORMALNY TU NIE WYSTAPI )
 156 cdsw&bc    1008 IF(STALER(ATS).EQ. 0.0)GO TO 9905
 157  1008 continue
 158 c
 159 C     WSTAW STALA REAL, SKOCZ DO WPISANIA WARTOSCI
 160       ATS=SCREAL(ATS)
 161       GO TO 9750
 162 C
 163 C
 164 C.....JESLI NIEPOTRZEBNA KONTROLA DYNAMICZNA - WPISZ WARTOSC
 165  1050 IF(CONTRL.LT.3 .OR. OPTTYP)GO TO 9750
 166       CONTRL=CONTRL-2
 167 C
 168       IDR=STACK(VALTOP-5)
 169 C     IDR = ZMODYFIKOWANY TYP FORMALNY PARAMETRU AKTUALNEGO LUB ZERO
 170 C
 171 C     CZY ZNANY OFFSET? /NIE,JESLI TO VIRTUAL LUB PARAMETR/
 172       IF(STACK(VLPREV-3).GE.16384)GO TO 1500
 173 C
 174 C
 175 C.....ZNANY OFFSET PARAMETRU.
 176 C
 177       GO TO(1100,1200,1300,1400),CONTRL
 178 C.....KONTROLA DYNAMICZNA, OBA TYPY ZNANE
 179  1100 CALL QUADR3(150,ATS,IPMEM(PARAM-3))
 180       GO TO 9800
 181 C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST FORMALNY,AKTUALNEGO ZNANY
 182  1200 IDR=STYPST(VALTOP)
 183       GO TO 1400
 184 C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST ZNANY,AKTUALNEGO FORMALNY
 185  1300 N=SPARST(PARAM)
 186       GO TO 1450
 187 C.....KONTROLA DYN.,TYPY PAR.FORMALNEGO I AKTUALNEGO SA FORMALNE
 188 cdsw 1400 N=SPARFT(PARAM)
 189 cdsw  -----------------------
 190  1400 n = sparft(param,1)
 191 cdsw  ------------------------
 192  1450 CALL QUADR4(170,N,ATS,IDR)
 193       GO TO 9800
 194 C
 195 C
 196 C..............NIEZNANY OFFSET PARAMETRU.
 197 C                    - TYP PAR.FORMALNEGO TRZEBA ODCZYTAC
 198 C     IDL,IDR = TYPY PAR.FORMALNEGO I AKTUALNEGO
 199  1500 CALL SPHADR(VLPREV)
 200       IF(CONTRL.LT.3)IDR=STYPST(VALTOP)
 201       CALL QUADR4(170,SFPRST(NRPAR),ATS,IDR)
 202       GO TO 9700
 203 C
 204 C.........PARAMETR INPUT PROCEDURY, FUNKCJI STANDARDOWEJ.
 205 C     ZAMIEN MIEJSCAMI OPISY PARAMETRU I FUNKCJI, TAK , BY FUNKCJA
 206 C       BYLA NAD SWOIMI ARGUMENTAMI.  / OBA OPISY ZAJMUJA PO 8 SLOW /
 207 C
 208  1800 DO 1810 K=0,7
 209          IDR=VALTOP-K
 210          IDL=VLPREV-K
 211          N=STACK(IDR)
 212          STACK(IDR)=STACK(IDL)
 213          STACK(IDL)=N
 214  1810 CONTINUE
 215 C     NA CZUBKU JEST FUNKCJA,PROCEDURA STANDARDOWA
 216 C     ZWIEKSZ LICZNIK PARAMETROW INPUT /SLOWO -2/
 217       STACK(VALTOP-2)=STACK(VALTOP-2)+1
 218 C     WPISZ NUMER PARAMETRU DO SLOWA -1
 219       STACK(VLPREV-1)=NRPAR
 220       RETURN
 221 C
 222 C
 223 C-------------------- PAR. O U T P U T ---------------
 224 C
 225 C     CZY PAR. AKTUALNY TO LSE?
 226  2000 IF(ELEM.GT.2 .AND. ELEM.LT.6)GO TO 2005
 227 C     NIEPOPRAWNY PARAMETR /AKTUALNY/ OUTPUT
 228       PARAM=471
 229       GO TO 9600
 230 C      O.K.       SPRAWDZ ZGODNOSC TYPOW
 231  2005 CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
 232      X    STACK(VALTOP-6))
 233 C     ZABEZPIECZ ADRES ZMIENNEJ
 234       CALL SAVEVAR(VALTOP)
 235 C.....WPISZ OPIS PARAMETRU AKTUALNEGO. CZY JEST MIEJSCE?
 236       IF(FSTOUT-VALTOP.GE.11)GO TO 2110
 237 C      BRAK MIEJSCA NA STOSIE NA DODATKOWE INFORMACJE O PARAMETRZE.
 238       PARAM=550
 239       GO TO 9600
 240 C     O.K. JEST MIEJSCE
 241  2110 CONTINUE
 242 C     ZWIEKSZ LICZNIK PARAMETROW OUTPUT
 243       STACK(VLPREV-3)=STACK(VLPREV-3)+1
 244 C     POSTAC OPISU PARAMETRU OUTPUT:
 245 C            OPIS ZAJMUJE 11 SLOW, OZNACZONYCH -9,..,0,+1
 246 C            SLOWA -9..0 ZAWIERAJA PRZEPISANY PAR.AKTUALNY
 247 C             /DLA ZMIENNEJ I ELEM.TABLICY SLOWA -9,-8 POZOSTAJA
 248 C              NIEWYKORZYSTANE/
 249 C            SLOWO -1 ZAMIAST NAZWY ZAWIERA ADRES W IPMEM OPISU PARAMETRU
 250 C                     FORMALNEGO
 251 C            SLOWO +1 = NUMER PARAMETRU /NRPAR/
 252 C            SLOWO 0 W BITACH 9-11 INFORMACJE O KONTROLI /MPARIO(..)/
 253 C
 254 C     WPISZ NUMER PARAMETRU
 255       STACK(FSTOUT-1)=NRPAR
 256 C     WPISZ RODZAJ ELEMENTU Z INFORMACJA O KONTROLI W BITACH 9-11
 257       STACK(FSTOUT-2)=ELEM+CONTRL*16
 258 C     WPISZ ADRES OPISU PAR.FORMALNEGO
 259       STACK(FSTOUT-3)=PARAM
 260 C     PRZEPISZ POZOSTALE 8 SLOW /BYC MOZE OSTATNIE 2 TO SMIECIE/
 261 C     APET,CONTRL = DOLNY,GORNY INDEKS
 262       APET=VALTOP-2
 263       CONTRL=FSTOUT-4
 264  2115 STACK(CONTRL)=STACK(APET)
 265       APET=APET-1
 266       CONTRL=CONTRL-1
 267       IF(CONTRL.GT.FSTOUT-12)GO TO 2115
 268 C     SLOWA VALTOP-0,..,VALTOP-9 PRZEPISANE NA MIEJSCA FSTOUT-2,..,FSTOUT-11.
 269 C
 270       FSTOUT=FSTOUT-11
 271       GO TO 9905
 272
 273 C
 274 C-------------------- PAR. T Y P E ---------------------
 275 C
 276 C     CZY PAR.AKTUALNY TO NAZWA TYPU,REKORD,KLASA?
 277  3000 IF(ELEM.LT.7 .OR. ELEM.GT.9)GO TO 3800
 278 C     O.K.
 279       CALL MPARTP(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-6),
 280      X         STACK(VALTOP-1))
 281 C     POBIERZ TYP
 282       ATS=STACK(VALTOP-2)
 283 C     =0 : KLASA,REKORD,TYP PIERWOTNY
 284 C     >0 : ATS WARTOSCI PAR.TYPE LUB PARAMETRU TYPE
 285       IF(ATS.EQ.0)ATS=STYPST(VALTOP)
 286       APET=2
 287       GO TO 9750
 288 C
 289 C.....UNIWERSALNY LUB NIEPOPRAWNY PARAMETR TYPE
 290  3800 CALL MPARTP(0,NRUNIV,0,STACK(VALTOP-1))
 291       IF(ELEM.EQ.0)GO TO 9905
 292       PARAM=472
 293       GO TO 9600
 294 C
 295 C------------- PAR. F U N C T I O N , P R O C E D U R E ------
 296 C
 297 C     CZY PAR.AKTUALNY JEST FUNKCJA LUB PROCEDURA?
 298  4000 IF(ELEM.EQ.11 .OR. ELEM.EQ.12)GO TO 4010
 299 C     NIEPOPRAWNY PAR. AKTUALNY
 300       PARAM=479-PARKIND
 301 C     = 473 LUB 474
 302       GO TO 9600
 303 C     FUNKCJA LUB PROCEDURA.
 304  4010 APET=STACK(VALTOP-4)
 305 C      = ADRES OPISU FUNKCJI,PROCEDURY
 306 C     CZY PAR.AKTUALNY JEST FUNKCJA,PROCEDURA STANDARDOWA ?
 307       IF(APET.GE.LPMSYS)GO TO 4020
 308 C     NIESTETY, TAK.
 309       PARAM=478
 310       GO TO 9600
 311  4020 CALL MPARPF(APET,STACK(VALTOP-1),STACK(VALTOP-6),DCONTR)
 312 C     JAKIEGO RODZAJU?
 313       KIND=0
 314 C     WEZ ZEROWE SLOWO OPISU
 315       APET=IPMEM(APET)
 316 C     VIRTUALNA,JESLI BIT 4 = 1
 317       IF(IAND(APET,SPARAHEX).NE.0)KIND=1
 318 C      LUB FORMALNA , JESLI BITY 8..11 = 2 LUB 3. WEZ TE BITY
 319       APET=IAND(ISHFT(APET,-4),15)
 320       IF(APET.EQ.2 .OR. APET.EQ.3)KIND=2
 321 C     WYLICZ NUMER PROTOTYPU I OJCA SYNTAKTYCZNEGO PARAMETRU
 322       ATS=SPRFLD(.TRUE.)
 323       APET=3
 324       GO TO 9750
 325 C
 326 C
 327 C
 328 C-------------------------------
 329 C
 330 C
 331 C.....WSPOLNA SYGNALIZACJA BLEDU.
 332 C     PARAM= NUMER BLEDU
 333  9600 CALL SERROR(PARAM)
 334       GO TO 9905
 335 C
 336 C
 337 C.....WPISANIE WARTOSCI PARAMETRU Z NIEZNANYM OFFSETEM
 338  9700 CONTRL=TSTEMP(1)
 339       CALL SPHADR(VLPREV)
 340 C     WEZ ADRES FIZYCZNY PARAMETRU
 341       CALL QUADR4(52,CONTRL,PHADR,NRPAR)
 342 C     WPISZ WARTOSC POD TEN ADRES
 343       CALL QUADR3(160+APET,CONTRL,ATS)
 344       GO TO 9900
 345 C
 346 C.....WPISANIE WARTOSCI. CZY ZNANY OFFSET?
 347  9750 IF(STACK(VLPREV-3).GE.16384)GO TO 9700
 348 C
 349 C.....WPISANIE WARTOSCI PARAMETRU ZE ZNANYM OFFSETEM
 350  9800 CONTINUE
 351       CALL SPHADR(VLPREV)
 352       CALL QUADR4(163+APET,PHADR,ATS,PARAM)
 353 C     WPISZ APET-SLOW DO POLA WSKAZANEGO PRZEZ ADRES FIZYCZNY PHADR
 354 C
 355 C
 356 C.....JUZ PO WSZYSTKIM-LUB PARAMETR UNIWERSALNY.
 357 C     CZY DYNAMICZNA KONTROLA NAGLOWKOW?
 358  9900 IF(.NOT.DCONTR)GO TO 9905
 359 C     TAK. ODTWORZ PELNY ADRES VIRTUALNY Z AH
 360       APET=TSTEMP(4)
 361       CALL QUADR3(43,APET,STACK(VLPREV-2))
 362       STACK(VLPREV-2)=APET
 363       CALL QUADR3(144,APET,NRPAR)
 364       PHADR=0
 365 C
 366 C
 367 C ... JESLI TO IN-OUT ,TO POTRAKTUJ GO TERAZ JAK INPUT
 368  9905 IF(PARKIND.EQ.7)GO TO 990
 369       CALL SPOP
 370 C
 371       RETURN
 372       END
 373       SUBROUTINE SVALU2
 374 C-----------------------------------------------------------------------------
 375 cdsw  procedura podzielona na svalue i svalue2 - entry usuniete
 376 C
 377 C     ENTRY SVALUE
 378 C
 379 C
 380 C     SPRAWDZA,CZY ELEMENT Z CZUBKA STOSU /SVALUE/ LUB PONIZEJ /SVALU2/
 381 C     REPREZENTUJE WARTOSC I WYLICZA TE WARTOSC.
 382 C     "UNIWERSALNY","STALA","WARTOSC" ZOSTAWIA BEZ ZMIAN.
 383 C     "ZMIENNA","ELEMTABLICY","TABLICA STATYCZNA","FUNKCJA"/BEZPARAMETROWA/
 384 C       ZASTEPUJE PRZEZ "WARTOSC" I JESLI SA TYPU FORMALNEGO TO POBIERA
 385 C     TEN TYP.  NIE MODYFIKUJE GO O LICZBE ARRAY-OF.
 386 C     POZOSTALE ZASTEPUJE PRZEZ "UNIWERSALNY" SYGNALIZUJAC BLAD.
 387 C
 388 C       WEJSCIE SVALUE - DLA CZUBKA STOSU
 389 C       WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
 390 C
 391 C     ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
 392 C
 393 C     ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
 394 C
 395 #include "stos.h"
 396 #include "blank.h"
 397 CCCCCCCCCCCCCCCCCCCC
 398       INTEGER ER(8)
 399 C      NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
 400 C
 401       INTEGER ATS,ELEM,APET
 402       DATA ER/452,451,451,0,450,0,453,454/
 403 C
 404       K=VLPREV
 405   100 ELEM=STACK(K)-2
 406 C     JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
 407       IF(ELEM.LE.0)RETURN
 408 C
 409 C     JESLI TYPU FORMALNEGO - WEZ TEN TYP
 410       IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
 411 C
 412 C     ZMIENNA PROSTA?
 413       IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
 414       IF(ELEM.GT.3)GO TO 600
 415 C
 416 C     WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
 417       APET=SAPET2(K)
 418
 419 #if WSIZE == 4
 420 cvax  changed because of real appettite = 1
 421       dswap = apet
 422       if (dswap .eq. 2) dswap = 1
 423       ats = tstemp(dswap)
 424 #else
 425       ATS=TSTEMP(APET)
 426 #endif
 427
 428       APET=APETYT(APET)
 429       GO TO (300,400,500),ELEM
 430 C.....ZMIENNA PRZEZ KROPKE. ODCZYTAJ APET-SLOW.
 431   300 CALL QUADR4(83+APET,ATS,SMEMBER(K),STACK(K-2))
 432 C     ZASTAP PRZEZ WARTOSC
 433   340 STACK(K-2)=ATS
 434   350 STACK(K)=2
 435       RETURN
 436 C
 437 C.....ELEM. TABLICY
 438   400 CALL QUADR3(60+APET,ATS,SARRAY(K))
 439       GO TO 340
 440 C
 441 C.....TABLICA STATYCZNA
 442   500 CONTINUE
 443 C     B R A K
 444 C...........
 445 C     JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
 446   600 IF(ELEM.NE.10)GO TO 3000
 447 C     FUNKCJA. /BEZPARAMETROWA/
 448       CALL SCALLB
 449 C     I TO WSZYSTKO.
 450       RETURN
 451 C
 452 C.....OBSLUGA BLEDOW
 453  3000 ELEM=ER(ELEM-4)
 454       CALL SERRO2(ELEM,K)
 455 C     ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
 456       STACK(K)=0
 457       RETURN
 458       END
 459       SUBROUTINE SVALUE
 460 C-----------------------------------------------------------------------------
 461 cdsw  procedura podzielona na svalue i svalue2 - entry usuniete
 462 C
 463 C     ENTRY SVALUE
 464 C
 465 C
 466 C     SPRAWDZA,CZY ELEMENT Z CZUBKA STOSU /SVALUE/ LUB PONIZEJ /SVALU2/
 467 C     REPREZENTUJE WARTOSC I WYLICZA TE WARTOSC.
 468 C     "UNIWERSALNY","STALA","WARTOSC" ZOSTAWIA BEZ ZMIAN.
 469 C     "ZMIENNA","ELEMTABLICY","TABLICA STATYCZNA","FUNKCJA"/BEZPARAMETROWA/
 470 C       ZASTEPUJE PRZEZ "WARTOSC" I JESLI SA TYPU FORMALNEGO TO POBIERA
 471 C     TEN TYP.  NIE MODYFIKUJE GO O LICZBE ARRAY-OF.
 472 C     POZOSTALE ZASTEPUJE PRZEZ "UNIWERSALNY" SYGNALIZUJAC BLAD.
 473 C
 474 C       WEJSCIE SVALUE - DLA CZUBKA STOSU
 475 C       WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
 476 C
 477 C     ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
 478 C
 479 C     ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
 480 C
 481 #include "stos.h"
 482 #include "blank.h"
 483 CCCCCCCCCCCCCCCCCCCC
 484       INTEGER ER(8)
 485 C      NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
 486 C
 487       INTEGER ATS,ELEM,APET
 488       DATA ER/452,451,451,0,450,0,453,454/
 489       K=VALTOP
 490   100 ELEM=STACK(K)-2
 491 C     JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
 492       IF(ELEM.LE.0)RETURN
 493 C
 494 C     JESLI TYPU FORMALNEGO - WEZ TEN TYP
 495       IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
 496 C
 497 C     ZMIENNA PROSTA?
 498       IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
 499       IF(ELEM.GT.3)GO TO 600
 500 C
 501 C     WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
 502       APET=SAPET2(K)
 503
 504 #if WSIZE == 4
 505 cvax  changed with real appetite = 1
 506       dswap = apet
 507       if (dswap .eq. 2) dswap = 1
 508       ats = tstemp(dswap)
 509 #else
 510       ATS=TSTEMP(APET)
 511 #endif
 512
 513       APET=APETYT(APET)
 514       GO TO (300,400,500),ELEM
 515 C.....ZMIENNA PRZEZ KROPKE. ODCZYTAJ APET-SLOW.
 516   300 CALL QUADR4(83+APET,ATS,SMEMBER(K),STACK(K-2))
 517 C     ZASTAP PRZEZ WARTOSC
 518   340 STACK(K-2)=ATS
 519   350 STACK(K)=2
 520       RETURN
 521 C
 522 C.....ELEM. TABLICY
 523   400 CALL QUADR3(60+APET,ATS,SARRAY(K))
 524       GO TO 340
 525 C
 526 C.....TABLICA STATYCZNA
 527   500 CONTINUE
 528 C     B R A K
 529 C...........
 530 C     JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
 531   600 IF(ELEM.NE.10)GO TO 3000
 532 C     FUNKCJA. /BEZPARAMETROWA/
 533       CALL SCALLB
 534 C     I TO WSZYSTKO.
 535       RETURN
 536 C
 537 C.....OBSLUGA BLEDOW
 538  3000 ELEM=ER(ELEM-4)
 539       CALL SERRO2(ELEM,K)
 540 C     ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
 541       STACK(K)=0
 542       RETURN
 543       END
 544       SUBROUTINE SVINT(ELEM)
 545 C-----------------------------------------------------------------------------
 546 C
 547 C     POMOCNICZA. ZASTEPUJE ELEMENT Z MIEJSCA ELEM STOSU /STALA,
 548 C     WARTOSC,ZMIENNA/ TYPU REAL PRZEZ STALA LUB WARTOSC TYPU INTEGER.
 549 C     GENERUJE KOD KONWERSJI.
 550 C     W PRZYPADKU STALEJ REAL O WARTOSCI WYKRACZAJACEJ POZA ZAKRES LICZB
 551 C      CALKOWITYCH SYGNALIZUJE ERROR 408  I ZASTEPUJE PRZEZ STALA INTEGER
 552 C       O TYM SAMYM ZNAKU I NAJWIEKSZYM MOZLIWYM MODULE.
 553 C
 554 C     ##### OUTPUT CODE : 58 .
 555 C
 556 C     ##### DETECTED ERROR(S) : 408 .
 557 C
 558 C
 559 #include "stos.h"
 560 #include "blank.h"
 561 C
 562 C
 563       REAL  X
 564       real y
 565       integer*2 m(2)
 566       equivalence (y, m(1))
 567 C
 568 #if WSIZE == 4
 569       DATA MAXINTEGER,MININTEGER / x'7FFFFFFF', x'80000000' /
 570 #else
 571       DATA MAXINTEGER,MININTEGER / x'7FFF', -x'7FFF' /
 572 #endif
 573 C
 574 C
 575 C.....
 576       STACK(ELEM-4)=NRINT
 577 C     CZY STALA?
 578       IF(STACK(ELEM).NE.1)GO TO 100
 579 C     TAK
 580       N=STACK(ELEM-2)
 581 C     SPRAWDZ WARTOSC STALEJ
 582 #if WSIZE == 4
 583       X=STALER(N)
 584 #else
 585       n1 = n*2-1
 586       m(1) = ipmem(n1)
 587       m(2) = ipmem(n1+1)
 588       x = y
 589 #endif
 590 c
 591       IF(X.LT.FLOAT(MININTEGER) .OR. X.GT.FLOAT(MAXINTEGER))GO TO 200
 592 CJF      STACK(ELEM-2)=IFIX(X)
 593 cdsw  STACK(ELEM-2)= IIDINT(X)
 594       stack(elem-2) = ifix(x)
 595       RETURN
 596 C     WARTOSC LUB ZMIENNA;    GENERUJ KONWERSJE
 597   100 N=TSTEMP(1)
 598       CALL QUADR3(58,N,STACK(ELEM-2))
 599       STACK(ELEM-2)=N
 600       STACK(ELEM)=2
 601       RETURN
 602 C     STALA REAL O WARTOSCI POZA ZAKRESEM LICZB CALKOWITYCH
 603   200 CALL SERRO2(408,ELEM)
 604 C     ZASTAP PRZEZ NAJWIEKSZA LICZBE CALKOWITA
 605       N=MAXINTEGER
 606       IF(X.LT.0.0)N=MININTEGER
 607       STACK(ELEM-2)=N
 608       RETURN
 609       END
 610       SUBROUTINE SVREAL(ELEM)
 611 C-----------------------------------------------------------------------------
 612 C
 613 C     POMOCNICZA. ZASTEPUJE ELEMENT /STALA,WARTOSC,ZMIENNA/ Z MIEJSCA
 614 C     ELEM STOSU TYPU INTEGER PRZEZ STALA LUB WARTOSC TYPU REAL.
 615 C
 616 C     ##### OUTPUT CODE : 59 .
 617 C
 618 C
 619 #include "stos.h"
 620 #include "blank.h"
 621 C
 622 C
 623       STACK(ELEM-4)=NRRE
 624 C     CZY TO STALA?
 625       IF(STACK(ELEM).NE.1)GO TO 100
 626 C     TAK
 627       STACK(ELEM-2)=CREAL(FLOAT(STACK(ELEM-2)))
 628       RETURN
 629 C     WARTOSC,ZMIENNA;        GENERUJ KONWERSJE
 630 #if WSIZE == 4
 631 100   n = tstemp(1)
 632 #else
 633 100   n = tstemp(2)
 634 #endif
 635       CALL QUADR3(59,N,STACK(ELEM-2))
 636       STACK(ELEM-2)=N
 637       STACK(ELEM)=2
 638       RETURN
 639       END
 640       SUBROUTINE SPUSH(ELEM)
 641 C------------------------------------------------------------------------
 642 C
 643 C     WSTAWIA NA STOS ELEMENT TYPU ELEM. USTAWIA VALTOP,VLPREV.
 644 C
 645 C     PRZY PRZEPELNIENIU STOSU PRZERYWA KOMPILACJE !!!
 646 C
 647 C     ( NA SKUTEK BRAKU NIELOKALNYCH SKOKOW NIE JEST MOZLIWY  )
 648 C     ( SKOK DO ETYKIETY 2000 W SPASS2 I KOMPILACJA KOLEJNYCH )
 649 C     ( MODULOW.                                              )
 650 C
 651 C
 652 C     ##### DETECTED ERROR(S) : 550.   /PRZEPELNIENIE STOSU  /
 653 C
 654 C
 655 #include "stos.h"
 656 #include "blank.h"
 657       VLPREV=VALTOP
 658       VALTOP=VALTOP+STCKAP(ELEM)
 659       IF(VALTOP.GE.FSTOUT)GO TO 100
 660       STACK(VALTOP)=ELEM
 661       RETURN
 662 C.....PRZEPELNIENIE STOSU
 663   100 CALL MERR(550,0)
 664 C     GO TO 2000   CHANGED TO COMMENT DUE TO A.I.L./P.G.     15.05.84
 665       call ffexit
 666 C     FOR STACK BEING OVERLOADED  STOP THE COMPILATION
 667 C     ' FATAL ERROR  '
 668       END
 669       SUBROUTINE SPOP
 670 C--------------------------------------------------------------------------
 671 C
 672 C     ZDEJMUJE 1 ELEMENT Z CZUBKA STOSU. USTAWIA VALTOP, VLPREV.
 673 C
 674 C
 675 #include "stos.h"
 676 #include "blank.h"
 677 C
 678       COMMON/SUMMARY/FREE
 679 C
 680 C
 681       N=FSTOUT-VALTOP-1
 682       IF(N.LT.FREE)FREE=N
 683 C
 684       VALTOP=VLPREV
 685       IF(VALTOP.LT.LSTSAF)LSTSAF=VALTOP
 686       VLPREV=STACK(VALTOP)
 687       VLPREV=STCKAP(VLPREV)
 688 C     =APETYT NOWEGO CZUBKA STOSU
 689       VLPREV=VALTOP-VLPREV
 690       RETURN
 691       END
 692       INTEGER FUNCTION SCONST(N)
 693 C-----------------------------------------------------------------------------
 694 C
 695 C     POMOCNICZA.
 696 C     ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA O WARTOSCI N.
 697 C
 698 C     ##### OUTPUT CODE : 199 .
 699 C
 700 C
 701 #include "stos.h"
 702 C
 703 C.....
 704       LSTEMP=LSTEMP-3
 705       SCONST=LSTEMP
 706       CALL QUADR3(199,SCONST,N)
 707       IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
 708       RETURN
 709       END
 710       INTEGER FUNCTION CREAL(X)
 711 C----------------------------------------------------------------
 712 C
 713 C     ZWRACA ADRES STALEJ X TYPU REAL W TABLICY STALYCH
 714 C
 715 C     ##### DETECTED ERROR(S) : 554 .
 716 C
 717       IMPLICIT INTEGER (A-Z)
 718 #include "blank.h"
 719 C
 720 C
 721       REAL   X
 722
 723 #if WSIZE == 4
 724 cvax  data realsize/1/
 725 cvax  the size of real numbers on vax is 4 bytes ( = the size of integer)
 726       i = lpmem+1
 727 100   if (staler(i) .eq.x) goto 200
 728       i = i+1
 729 cail      if (i .lt. irecn) goto 100
 730       if (i .le. irecn) goto 100
 731 Cail  constant not found, i=irenc+1, append if enough room
 732       if (irecn+1 .gt. ipmem(lmem)) goto 300
 733       irecn = irecn + 1
 734       staler(i) = x
 735 200   creal = i
 736 #else
 737       real y
 738       integer*2 m(2)
 739       equivalence (y, m(1))
 740       INTEGER REALSIZE
 741       DATA REALSIZE/2/
 742       y = x
 743       i = lpmem + 1
 744   100 if (ipmem(i) .eq. m(1) .and. ipmem(i+1) .eq. m(2)) goto 200
 745       i = i + 2
 746       if (i .lt. irecn) goto 100
 747       if (irecn + 2 .gt. ipmem(lmem)) goto 300
 748       irecn = irecn + 2
 749       ipmem(i  ) = m(1)
 750       ipmem(i+1) = m(2)
 751   200 creal = (i+1) / 2
 752       n1 = creal*2-1
 753       m(1) = ipmem(n1)
 754       m(2) = ipmem(n1+1)
 755 #endif
 756
 757 cdsw&bc C                     = SIZE OF REAL VALUE (NUMBER OF WORDS)
 758 cdsw&bc C     LPMEM=INDEKS OSTATNIEGO SLOWA PRZEZ STALYMI REAL
 759 cdsw&bc C     IRECN=INDEKS OSTATNIEGO SLOWA ZAJETEGO PRZEZ STALE REAL
 760 cdsw&bc       N=(IRECN / REALSIZE)+1
 761 cdsw&bc C        = INDEKS PIERWSZEGO WOLNEGO MIEJSCA W STALER
 762 cdsw&bc       CREAL=(LPMEM+REALSIZE-1)/REALSIZE+1
 763 cdsw&bc C        = INDEKS PIERWSZEJ STALEJ W STALER
 764 cdsw&bc C     USTAW WARTOWNIKA
 765 cdsw&bc       STALER(N)=X
 766 cdsw&bc   100 IF(STALER(CREAL).EQ.X)GO TO 200
 767 cdsw&bc       CREAL=CREAL+1
 768 cdsw&bc       GO TO 100
 769 cdsw&bc C     JEST?
 770 cdsw&bc   200 IF(CREAL.LT.N)RETURN
 771 cdsw&bc       IF(IRECN+REALSIZE .GT. IPMEM(LMEM))GO TO 300
 772 cdsw&bc       IRECN=IRECN+REALSIZE
 773       RETURN
 774   300 CALL SERRO2(554,0)
 775       RETURN
 776       END
 777       INTEGER FUNCTION SCREAL(N)
 778 C----------------------------------------------------------------------------
 779
 780 C     POMOCNICZA.
 781 C     ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA REAL O NUMERZE N
 782 C
 783 C     ##### OUTPUT CODE : 197 .
 784 C
 785 #include "stos.h"
 786 #include "blank.h"
 787 C
 788 C
 789 #if WSIZE == 4
 790       data realsize /1/
 791 #else
 792       data realsize /2/
 793 #endif
 794
 795 C                     = SIZE OF REAL VALUE (NUMBER OF WORDS)
 796 C     LPMEM=INDEKS OSTATNIEGO SLOWA PRZEZ STALYMI REAL
 797 C.....
 798       LSTEMP=LSTEMP-3
 799       SCREAL=LSTEMP
 800       K=(LPMEM+REALSIZE-1)/REALSIZE+1
 801 C     K=INDEKS PIERWSZEJ STALEJ W STALER
 802       K=REALSIZE*(N-K)
 803 C       = OFFSET WZGLEDEM ETYKIETY "RECON" RUN-TIME-U.
 804       CALL QUADR3(197,SCREAL,K)
 805       IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
 806       RETURN
 807       END
 808
 809       INTEGER FUNCTION SWHAT(IND)
 810 C----------------------------------------------------------------------------
 811 C
 812 C
 813 C     IND WSKAZUJE ZEROWE SLOWO OPISU ATRYBUTU /IND=MIDENT(NAZWA)/.
 814 C     FUNKCJA ROZPOZNAJE RODZAJ ATRYBUTU I ZWRACA JAKO WYNIK :
 815 C                   0 - "UNIWERSALNY"
 816 C                   1 - "STALA"
 817 C                   3 - "ZMIENNA"
 818 C                   5 - "TABLICA STATYCZNA"
 819 C                   7 - "TYP FORMALNY" / "NAZWA TYPU"/
 820 C                   8 - "REKORD"
 821 C                   9 - "KLASA"
 822 C                  11 - "PROCEDURA"
 823 C                  12 - "FUNKCJA"
 824 C                  13 - "SYGNAL"
 825 C                  14 - "OPERATOR"
 826 C
 827 C     W PRZYPADKU NIEPOPRAWNEGO OPISU ZWRACA UNIWERSALNY.
 828 C.....
 829       IMPLICIT INTEGER (A-Z)
 830 #include "blank.h"
 831 C
 832 C
 833 CCCCCCCCCCCCCCCCCCCCCCCCC
 834       INTEGER TT(35),TT0(36)
 835       EQUIVALENCE (TT0(2),TT(1))
 836       DATA TT0/0,0,8,9,0,9,7,9,8*0,
 837      X    3,3,3,1,3,14,13,13,4*0,
 838      X    0,10,12,12,11,11,10,13/
 839 C      = RODZAJ ATRYBUTU :
 840 C         ELEMENTY 0..15 ODPOWIADAJA WARTOSCIOM 0..15 POLA "T"
 841 C            "    16..27      "        "        5..16 POLA "ZP"
 842 C            "    28..35      "        "        0..7  POLA "S"
 843 C
 844 C............
 845       N=IPMEM(IND)
 846 C ... ODCZYTAJ POLE "T" , BITY 12..15
 847       K=IAND(N,15)
 848       IF(K.NE.1)GO TO 200
 849 C ... NIE TYP. POLE "ZP" , BITY 8..11
 850       L=IAND(ISHFT(N,-4),15)
 851       IF(L.GT.4)GO TO 150
 852 C ... PROCEDURA,FUNKCJA, POLE "S" , BITY 5..7
 853       L=IAND(ISHFT(N,-8),7)+17
 854   150 K=L+11
 855   200 SWHAT=TT(K)
 856       RETURN
 857       END
 858       SUBROUTINE SCALLB
 859 C-----------------------------------------
 860 C
 861 C     WERSJA 1983.04.26
 862 C
 863 C     POCZATEK WYWOLANIA. CZUBEK STOSU ZAWIERA REKORD,KLASE,FUNKCJE,
 864 C     PROCEDURE,BLOK PREF,SYGNAL.
 865 C     JESLI NA STOSIE JEST MODUL BEZ PELNEGO ADR.VIRTUALNEGO
 866 C      /TYLKO ADR.POSREDNI , GDY LASTPR <> 0 / , TO ZASTEPUJE TEN ADRES
 867 C        PRZEZ PELNY ADR.VIRTUALNY.
 868 C     OTWIERA POLE DANYCH /PO WYZNACZENIU DYNAMICZNEGO PROTOTYPU WRAZ Z
 869 C     OTOCZENIEM/ - O ILE NIE JEST TO PROCEDURA,FUNKCJA STANDARDOWA
 870 C     PRZY BRAKU PARAMETROW FORMALNYCH / WB<>"(" / PRZECHODZI DO ZAKONCZENIA
 871 C      WYWOLANIA /WOLA SCALLE/. UWAGA: DLA FUNKCJI BEZPARAMETROWEJ WOLA
 872 C       SCALLE NAWET DLA WB="(".
 873 C
 874 C     USTAWIA BITY 0-2 SLOWA -3 :
 875 C                000 =  ZWYKLY,LOKALNY MODUL BEZ PREFIKSU,
 876 C                001 =  NIELOKALNY LUB PREFIKSOWANY,ALE ZNANE OFFSETY,
 877 C                010 =  NIEZNANE OFFSETY PARAMETROW /VIRTUAL LUB PARAMETR/
 878 C           INFORMACJA TA JEST UZYWANA PRZEZ SPARAM,SCALLE .
 879 C
 880 C     WOLANA PRZEZ SDPDA: DLA NAZWY LUB NAZWY PO KROPCE KLASY,REKORDU,
 881 C          FUNKCJI,PROCEDURY,SYGNALU ORAZ DLA BLOKU PREF.
 882 C     WOLANA PRZEZ SVALUE: GDY NAZWA LUB NAZWA PO KROPCE KLASY,REKORDU,FUNKCJI
 883 C     WYSTAPILA PRZED "," LUB ")" .
 884 C
 885 C     DLA FUNKCJI (NIE-STANDARDOWEJ) GASI FLREADY.
 886 C
 887 C     ##### OUTPUT CODE : 1 , 3 , 4 , 5 , 43 .
 888 C
 889 C
 890 #include "stos.h"
 891 #include "blank.h"
 892 C
 893       INTEGER ELEM,IND,OPKOD,ADR,PROT,BT
 894 cdsw  DATA SCALBHX1,SCALBHX2 /Z2000, Z4000 /
 895       data schx1, schx2 / x'2000', x'4000' /
 896 C      RODZAJ ELEMENTU,ADRES PROTOTYPU W IPMEM
 897 C................
 898       ELEM=STACK(VALTOP)
 899       IND=STACK(VALTOP-4)
 900       PROT=IND
 901 C
 902 C..... ROZPOCZNIJ KONTROLE PARAMETROW
 903       CALL MCALLO(IND,STACK(VALTOP-1),STACK(VALTOP-6),KIND)
 904 cbc moved check for virtual address before check for standard procedure
 905 C     CZY JEST NA STOSIE WYWOLANIE WYMAGAJACE ZABEZPIECZENIA ADR. WIRTUALNEGO
 906       IF(LASTPR.EQ.0)GO TO 200
 907 C     TAK. WEZ PELNY ADRES VIRTUALNY
 908       N=TSTEMP(4)
 909       CALL QUADR3(43,N,STACK(LASTPR-2))
 910       STACK(LASTPR-2)=N
 911 200   continue
 912 C.....FUNKCJA,PROCEDURA STANDARDOWA ?
 913       IF(IND.LT.LPMSYS)GO TO 1000
 914 C     NIE.
 915       FLREADY=.FALSE.
 916 cbc
 917       LASTPR=VALTOP
 918       PHADR=TSTEMP(1)
 919       N=ELEM-7
 920 C     =RODZAJ ELEMENTU, 1..7 ZAMIAST 8..14
 921       BT=schx1
 922 C     = BITY 0-1 KOPIOWANE DO SLOWA -1 , = ZNANE OFFSETY,NIELOKALNY LUB PREF.
 923       GO TO (220,260,350,240,240,230),N
 924 C      - OPERATOR TU NIE WYSTAPI
 925 C
 926 C.....REKORD
 927   220 ADR=TSTEMP(4)
 928       OPKOD=1
 929       GO TO 400
 930 C.....SYGNAL
 931   230 OPKOD=3
 932       PROT=IPMEM(PROT+1)
 933 C      = NUMER SYGNALU
 934       GO TO 380
 935 C.....PROCEDURA,FUNKCJA. VIRTUAL LUB PARAMETR ?
 936   240 IF(KIND.EQ.0)GO TO 260
 937       BT=schx2
 938 C               CZYLI NIEZNANE OFFSETY
 939       GO TO 270
 940 C.....KLASA, CD. PROCEDURY,FUNKCJI
 941 C     LOKALNY BEZ PREFIKSU ?
 942   260 IF(LOCAL.EQ.2 .AND. IPMEM(PROT+21).EQ.0 .AND. STACK(VALTOP-7)
 943      X .EQ.0) BT=0
 944   270 IF(KIND.NE.2 .AND. STACK(VALTOP-7).EQ.0)GO TO 350
 945       OPKOD=5
 946       GO TO 360
 947 C.....BLOK PREFIKSOWANY
 948   350 OPKOD=4
 949   360 PROT=SPRFLD(.FALSE.)
 950 C      = WYZNACZONY DYNAMICZNIE PROTOTYP /BYC MOZE WRAZ Z OTOCZENIEM/
 951   380 ADR=TSTEMP(1)
 952 C.....WSPOLNE OTWARCIE POLA DANYCH : OPENRC,RAISE,OPEN,SLOPEN
 953 C                                /OPKOD = 1,3,4,5/
 954   400 CALL QUADR4(OPKOD,ADR,PHADR,PROT)
 955       STACK(VALTOP-2)=ADR
 956       STACK(VALTOP-3)=BT
 957 C     OTWARCIE POLA DANYCH   DOSTARCZA AH I ADR.FIZYCZNEGO
 958 C.....CZY SA PARAMETRY AKTUALNE ?
 959   500 IF(WB.EQ.36)GO TO 550
 960 C     BRAK PAR.AKTUALNYCH, KONCZ WYWOLANIE
 961   510 CALL SCALLE
 962       RETURN
 963 C     DLA FUNKCJI BEZPARAMETROWEJ TEZ KONCZ WYWOLANIE
 964   550 IF(ELEM.EQ.12 .AND. IPMEM(IND+4).EQ.1)GO TO 510
 965       RETURN
 966 C.....PROCEDURA,FUNKCJA STANDARDOWA
 967  1000 STACK(VALTOP-2)=0
 968       STACK(VALTOP-3)=0
 969 C     WYZEROWANE LICZNIKI PAR. INPUT I OUTPUT
 970       GO TO 500
 971       END
 972       SUBROUTINE SCALLE
 973 C-------------------------------------------------------------------------
 974 C
 975 C     WERSJA 1984.04.10
 976 C
 977 C     OBSLUGUJE ZAKONCZENIE WYWOLANIA REKORDU,KLASY,BLOKU PREF.,
 978 C        PROCEDURY,FUNKCJI,SYGNALU.
 979 C
 980 C     WOLANA : PRZY BRAKU PARAMETROW AKTUALNYCH PRZEZ SCALLB LUB
 981 C          PO WYSTAPIENIU ")" PRZEZ SDPDA.
 982 C
 983 C     WOLA MCALLC.
 984 C     ZABEZPIECZA STOS.
 985 C     PRZEKAZUJE STEROWANIE.
 986 C     ODCZYTUJE PARAMETRY OUTPUT I WARTOSC FUNKCJI.
 987 C     SPRAWDZA DLA PROCEDURY ISTNIENIE "CALL" I ZJADA. /JESLI BRAK "CALL"
 988 C      - ZASTEPUJE PRZEZ UNIWERSALNY/
 989 C     DLA SYGNALU SPRAWDZA ISTNIENIE "RAISE" I ZJADA /JESLI BRAK "RAISE"
 990 C      - ZASTEPUJE  PRZEZ UNIWERSALNY.
 991 C     REKORD,KLASE ZASTEPUJE PRZEZ WARTOSC / LUB ZDEJMUJE ZE STOSU
 992 C       JESLI WB = ZNACZNIK KONCA INSTRUKCJI LUB ETYKIETA /.
 993 C     FUNKCJE ZASTEPUJE PRZEZ WARTOSC.
 994 C     DLA BLOKU PREF.,PROCEDURY,SYGNALU OBNIZA STOS.
 995 C     DLA FUNKCJI,PROCEDURY,SYGNALU,BLOKU PREF. USUWA POLE DANYCH.
 996 C
 997 C
 998 C     DLA PROCEDURY,FUNKCJI STANDARDOWEJ GENERUJE :
 999 C       PRZEKAZANIE WARTOSCI PARAMETROW INPUT /OPKOD 145/ ,
1000 C       PRZEKAZANIE STEROWANIA /OPKOD 132/ ,
1001 C       ODCZYT PAR. OUTPUT I WARTOSCI FUNKCJI /OPKOD 23/
1002 C       PRZEKAZANIE ODCZYTANYCH WARTOSCI PARAMETROW NA PAR.AKTUALNE
1003 C      ORAZ ZDEJMUJE ZE STOSU PARAMETRY INPUT LEZACE POD FUNKCJA,PROCEDURA.
1004 C      DODATKOWO, FUNKCJE ZASTEPUJE PRZEZ WARTOSC.
1005 C
1006 C
1007 C
1008 C     ##### OUTPUT CODE : 2 , 21 , 54 , 58 , 59 , 132 , 143 , 145 ,
1009 C                            150 , 153 , 159 , 160 , 170 .
1010 C
1011 C     ##### DETECTED ERROR(S) : 450 , 453 .
1012 C
1013 #include "stos.h"
1014 #include "option.h"
1015 #include "blank.h"
1016 C
1017 C
1018       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
1019      * MPROCES, MCOR, MERPF, MBLOCK, MHAND
1020      *, MNOTVIR
1021 C
1022 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
1023 C   MASKI I WZORCE:
1024 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
1025 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
1026 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
1027 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
1028 C    MASKTP - ZAPRZECZENIE MASKI  MTP
1029 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
1030 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
1031 C    MCOR - WZORZEC DLA COROUTINY (7)
1032 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
1033 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
1034 C    MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
1035 C    MHAND - WZORZEC DLA HANDLERA
1036 C
1037 CCCCCCCCCCCCCCCCCCCCCCCCCC
1038       INTEGER OPKOD,N,ELEM,CONTRL,IND,ATS,M
1039       LOGICAL STANDARD
1040       DATA SCALEHEX / x'1FFF' /
1041 C       ELEM - WSKAZUJE 0-SLOWO OPISU PARAMETRU NA STOSIE
1042 C       CONTRL - INFORMACJA O KONTROLI /MPARIO(..)+1/
1043 C       IND - ADRES W IPMEM OPISU PAR.FORMALNEGO
1044 C       ATS - ATS WARTOSCI PAR.FORMALNEGO LUB WARTOSCI FUNKCJI
1045 C       STANDARD - .TRUE. DLA PROCEDURY,FUNKCJI STANDARDOWEJ
1046 C
1047 C......
1048       CALL MCALLC
1049       KIND=0
1050 C.....FUNKCJA,PROCEDURA STANDARDOWA ?
1051       STANDARD=( STACK(VALTOP-4) .LT. LPMSYS )
1052       IF(STANDARD)GO TO 2000
1053 C     NIE.
1054 C     JESLI REKORD - PRZESKOCZ
1055       IF(STACK(VALTOP).EQ.8)GO TO 50
1056 C.....ZABEZPIECZ STOS
1057       CALL SAFEST
1058 C.....PRZEKAZ STEROWANIE
1059       CALL SPHADR(VALTOP)
1060       OPKOD=160
1061       IF(STACK(VALTOP-3).GT.8191)OPKOD=159
1062 C     GOLOCAL LUB GO
1063 C     PRZEKAZ STEROWANIE Z ADRESEM FIZYCZNYM I AH NOWEGO OBIEKTU
1064       CALL QUADR3(OPKOD,PHADR,STACK(VALTOP-2))
1065 C
1066 C
1067 C     PO POWROCIE Z GENEROWANEGO OBIEKTU:
1068 C
1069 C
1070       PHADR=TSTEMP(1)
1071       ATS=TSTEMP(4)
1072       STACK(VALTOP-2)=ATS
1073 C     NOWE ATS-Y NA ADR.FIZ. I VIRTUALNY
1074       CALL QUADR3(2,ATS,PHADR)
1075 C
1076 C
1077 C     CZY PROC. VIRTUALNA LUB FORMALNA? TAK,JESLI BIT 1 =1 W SLOWIE -3
1078       IF(STACK(VALTOP-3).GE.16384)KIND=1
1079 C      -OBOJETNE: FORMALNA CZY VIRTUALNA /CZY ZNANE OFFSETY/
1080 C
1081 C
1082 C
1083 C.....JESLI SA PARAMETRY OUTPUT-ODCZYTAJ WARTOSCI
1084    50 M=IAND(STACK(VALTOP-3),SCALEHEX)
1085 C     M=LICZBA PARAMETROW OUTPUT
1086       IF(M.EQ.0)GO TO 500
1087 C     DLA PROCEDURY STANDARDOWEJ NAJPIERW ODCZYTAJ WARTOSCI WSZYSTKICH
1088 C       PARAMETROW
1089       IF(.NOT.STANDARD)GO TO 100
1090       ELEM=FSTOUT-2
1091       DO 90 N=1,M
1092 C       ODCZYTAJ WARTOSC N-TEGO PAR.OUTPUT PROC.STANDARDOWEJ
1093 C        I WPISZ ATS TEJ WARTOSCI DO SLOWA -8
1094         ELEM=ELEM+11
1095         IND=STACK(ELEM-1)
1096         NRPAR=STACK(ELEM+1)
1097    90   STACK(ELEM-8)=SGETPAR(IND,VALTOP)
1098 C
1099   100 CONTINUE
1100 C
1101       DO 400 N=1,M
1102 C       OBSLUZ N-TY PARAMETR OUTPUT /OD PRAWEJ DO LEWEJ/
1103         FSTOUT=FSTOUT+11
1104         ELEM=FSTOUT-2
1105         CONTRL=IAND(ISHFT(STACK(ELEM),-4),7)+1
1106         STACK(ELEM)=IAND(STACK(ELEM),15)
1107 C       ODCZYTANE I WYZEROWANE BITY 9-11
1108         IND=STACK(ELEM-1)
1109         NRPAR=STACK(ELEM+1)
1110         IF(STANDARD)GO TO 102
1111 C       ODCZYTAJ WARTOSC PARAMETRU OUTPUT
1112         ATS=SGETPAR(IND,VALTOP)
1113         GO TO 103
1114   102   ATS=STACK(ELEM-8)
1115 C
1116 C       KONWERSJA LUB DYNAMICZNA KONTROLA
1117   103   IF(CONTRL.GT.3 .AND.OPTTYP)GO TO 300
1118 C
1119         IDR=STACK(ELEM-5)
1120         IF(IDR.EQ.0)GO TO 105
1121         IDR=STYPFT(ELEM)
1122 C       IDR = TYP FORMALNY PAR.AKT. LUB ZERO
1123 C
1124   105   GO TO (300,110,120,130,140,150,160),CONTRL
1125 C
1126 C       KONWERSJA DO INTEGER
1127   110   OPKOD=TSTEMP(1)
1128         CALL QUADR3(58,OPKOD,ATS)
1129         ATS=OPKOD
1130         GO TO 300
1131 C
1132 C       KONWERSJA DO REAL
1133 #if WSIZE == 4
1134 120     opkod = tstemp(1)
1135 #else
1136 120     opkod = tstemp(2)
1137 #endif
1138         CALL QUADR3(59,OPKOD,ATS)
1139         ATS=OPKOD
1140         GO TO 300
1141 C
1142 C       KONTROLA DYN.,OBA TYPY STATYCZNE
1143   130   CALL QUADR3(150,ATS,STACK(ELEM-4))
1144         GO TO 300
1145 C
1146 C.....ZNANY OFFSET?
1147   140   IF(KIND.NE.0)GO TO 165
1148         OPKOD=TSTEMP(2)
1149         CALL QUADR4(21,OPKOD,IPMEM(IND-4),IPMEM(IND-3))
1150         GO TO 200
1151 C       WSTAW TYP STATYCZNY PAR.AKTUALNEGO
1152   150  IDR=STYPST(ELEM)
1153 C       ZNANY OFFSET?
1154   160   IF(KIND.EQ.0)GO TO 170
1155 C       NIEZNANY. ODCZYTAJ TYP PAR.FORMALNEGO
1156   165   OPKOD=SFPRST(NRPAR)
1157         GO TO 200
1158 C       ZNANY OFFSET
1159 cdsw  170   OPKOD=SPARF2(IND)
1160 cdsw  ----------------------------
1161  170   opkod = sparft(ind,2)
1162 cdsw  -----------------------------
1163 C
1164 C       OPKOD=ATS ODCZYTANEGO TYPU FORMALNEGO PAR.FORMALNEGO.
1165   200   CALL QUADR4(170,IDR,ATS,OPKOD)
1166 C       ZAKONCZONA KONTROLA LUB KONWERSJA.
1167 C       PODSTAW WARTOSC PAR.OUTPUT NA PAR.AKTUALNY
1168   300   CALL SSTORE(ELEM,ATS)
1169 C       ZAKONCZONA OBSLUGA KOLEJNEGO PARAMETRU OUTPUT
1170 C
1171   400 CONTINUE
1172 C
1173 C
1174   500 ELEM=STACK(VALTOP)-7
1175 C      = RODZAJ ELEMENTU : 1..6 ZAMIAST 8..13 /OPERATOR TU NIE WYSTAPI/
1176       GO TO (600,600,800,700,900,650),ELEM
1177 C.....KLASA,REKORD. ZASTAP PRZEZ WARTOSC
1178   600 STACK(VALTOP)=2
1179       STACK(VALTOP-3)=0
1180       STACK(VALTOP-5)=0
1181 cbc kill template after return from process (opcode 222 LKILLTEMP)
1182       prot = ipmem(stack(valtop-4))
1183       if (iand(prot, mtp) .eq. mproces)  call quadr1(222)
1184 cbc
1185 C     JESLI NA WEJSCIU JEST POCZATEK INSTRUKCJI LUB ETYKIETA - ZDEJMIJ
1186 C      ZE STOSU
1187       IF(WB.EQ.32 .OR. WB.EQ.35 .OR. WB.EQ.44)CALL SPOP
1188       GO TO 1000
1189 C.....SYGNAL. CZY JEST "RAISE" ?
1190   650 IF(WB.EQ.71)GO TO 670
1191 C     BRAK RAISE - NIELEGALNE WYSTAPIENIE SYGNALU.ZASTAP PRZEZ UNIWERSALNY
1192       CALL SERROR(453)
1193       GO TO 720
1194 C     ETYKIETA I USUNIECIE POLA DANYCH HANDLERA
1195   670 CALL SNEXT
1196       IDL=153
1197       GO TO 810
1198 C.....PROCEDURA. CZY JEST CALL?
1199   700 IF(WB.EQ.7)GO TO 750
1200 C     BRAK CALL - NIELEGALNE WYSTAPIENIE PROCEDURY. ZASTAP PRZEZ UNIWERSALNY
1201       CALL SERROR(450)
1202   720 STACK(VALTOP)=0
1203       GO TO 1000
1204 C
1205   750 CALL SNEXT
1206 C     PROCEDURA STANDARDOWA ?
1207       IF(STACK(VALTOP-4).LT.LPMSYS)GO TO 3000
1208 C     NIE.
1209 C.....BLOK PREFIKSOWANY. OBNIZ STOS,USUN POLE DANYCH
1210   800 IDL=143
1211   810 CALL QUADR2(IDL,STACK(VALTOP-2))
1212       CALL SPOP
1213       GO TO 1000
1214 C.....FUNKCJA. ZASTAP PRZEZ WARTOSC
1215 C     WEZ DLA RESULT: NUMER JAKO PARAMETRU, ADRES OPISU JAKO ATRYBUTU
1216   900 N=STACK(VALTOP-4)
1217 C     N=ADRES OPISU FUNKCJI W IPMEM
1218 C     PARAMETRY SA NUMEROWANE OD ZERA, RESULT WYSTEPUJE JAKO OSTATNI.
1219       NRPAR=IPMEM(N+4)-1
1220       IND=IPMEM(N-5)
1221       RESULT=SGETPAR(IND,VALTOP)
1222 C      =  ATS ODCZYTANEJ WARTOSCI FUNKCJI
1223 C     FUNKCJA STANDARDOWA ?
1224       IF(N.LT.LPMSYS)GO TO 4000
1225 C     NIE.
1226 C     WSTAW TYP WARTOSCI
1227       STACK(VALTOP-3)=IPMEM(N-4)
1228       STACK(VALTOP-4)=IPMEM(N-3)
1229 C     CZY TYPU FORMALNEGO?
1230       STACK(VALTOP-5)=0
1231       IF(IAND(IPMEM(N),4096).EQ.0)GO TO 950
1232 C     A WIEC FUNKCJA TYPU FORMALNEGO. ZWYKLA ?
1233       IF(KIND.EQ.1) GO TO 930
1234 C     TAK. IDAC PO SL-ACH OD POLA DANYCH ODCZYTAJ TEN TYP
1235       N=TSTEMP(2)
1236       CALL QUADR4(54,N,STACK(VALTOP-2),STACK(VALTOP-4))
1237       GO TO 940
1238 C     FUNKCJA FORMALNA LUB WIRTUALNA TYPU FORMALNEGO. ODCZYTAJ TEN TYP>
1239   930 N=SFPRST(NRPAR)
1240   940 STACK(VALTOP-5)=N
1241 C
1242 C     ZASTAP PRZEZ WARTOSC
1243   950 STACK(VALTOP)=2
1244 C     USUN POLE DANYCH
1245       CALL QUADR2(143,STACK(VALTOP-2))
1246       STACK(VALTOP-2)=RESULT
1247 C
1248 C...............WSPOLNE ZAKONCZENIE..............
1249  1000 PHADR=0
1250       LASTPR=0
1251       RETURN
1252 C
1253 C.....FUNKCJA,PROCEDURA STANDARDOWA.
1254 C         WPISZ WARTOSCI PARAMETROW INPUT.
1255  2000 OPKOD=STACK(VALTOP-4)
1256       OPKOD=IPMEM(OPKOD+2)
1257 C     = NUMER FUNKCJI STANDARDOWEJ
1258 C     WYMAGA SPECJALNEGO TRAKTOWANIA ?
1259       IF(OPKOD.GT.0)GO TO 2100
1260 C     TAK
1261       CALL SPECIAL
1262       RETURN
1263 C ... NORMALNIE OBSLUGIWANA
1264  2100 M=VALTOP-8*STACK(VALTOP-2)
1265 C     = ADRES PIERWSZEGO PAR.INPUT
1266 C     CZY SA / JESZCZE / PARAMETRY INPUT ?
1267  2200 IF(M.GE.VALTOP)GO TO 2400
1268 C     WPISZ WARTOSC PARAMETRU
1269       CALL QUADR4(145,SVATS(M),OPKOD,STACK(M-1))
1270       M=M+8
1271       GO TO 2200
1272 C
1273 C ... PRZEKAZ STEROWANIE
1274  2400 CALL QUADR2(132,OPKOD)
1275       GO TO 50
1276 C
1277 C.....ZAKONCZENIE DLA PROCEDURY STANDARDOWEJ.
1278 C       ZDEJMIJ ZE STOSU WRAZ Z PARAMETRAMI INPUT
1279  3000 OPKOD=STACK(VALTOP-2)+1
1280       IF (OPKOD.LT.1)GO TO 3150
1281       DO 3100 M=1,OPKOD
1282       CALL SPOP
1283  3100 CONTINUE
1284 cbc 3150 RETURN
1285  3150 goto 1000
1286 cbc
1287 C
1288 C.....ZAKONCZENIE DLA FUNKCJI STANDARDOWEJ.
1289 C     ZASTAP FUNKCJE WRAZ Z PARAMETRAMI INPUT PRZEZ WARTOSC
1290  4000 OPKOD=STACK(VALTOP-2)
1291       IF (OPKOD.LT.1)GO TO 4150
1292       DO 4100 M=1,OPKOD
1293       CALL SPOP
1294  4100 CONTINUE
1295  4150 CALL SRESLT1(IPMEM(N-3))
1296       STACK(VALTOP-3)=IPMEM(N-4)
1297 cbc   RETURN
1298       goto 1000
1299 cbc
1300       END
1301       SUBROUTINE SPECIAL
1302 C----------------------------------------------------------------------------
1303 C
1304 C     OBSLUGUJE WYWOLANIE FUNKCJI STANDARDOWYCH WYMAGAJACYCH
1305 C       SPECJALNEJ OBSLUGI :
1306 C
1307 C     NUMERY :
1308 C       -1   INOT
1309 C       -2   IOR
1310 C       -3   IAND
1311 C       -4   ISHFT
1312 C       -5   ORD
1313 C       -6   CHR
1314 C       -7   XOR
1315 C
1316 C     NA CZUBKU STOSU ZNAJDUJE SIE FUNKCJA,POD NIA ARGUMENTY.
1317 C     PROCEDURA GENERUJE KOD I ZASTEPUJE NA STOSIE FUNKCJE WRAZ
1318 C      Z PARAMETRAMI PRZEZ JEJ WARTOSC.
1319 C
1320 C     ##### OUTPUT CODE : 42 , 53 , 60 , 100 , 101 , 116 , 131 .
1321 C
1322 C
1323 #include "stos.h"
1324 #include "blank.h"
1325 C
1326 C
1327       INTEGER ARGS(7)
1328 C      = LICZBA ARGUMENTOW
1329       INTEGER OP(8)
1330 C      = OPKOD DO WYPISANIA
1331 C
1332       DATA ARGS/1,2,2,2,1,1,2/
1333       DATA OP/42,100,101,116,60,60,131,53/
1334 C
1335 C
1336       IND=STACK(VALTOP-4)
1337 C     = ADRES OPISU FUNKCJI
1338       N=STACK(VALTOP-2)
1339 C     = LICZBA PAR. INPUT NA STOSIE , <= ARGS( .. )
1340       NR=-IPMEM(IND+2)
1341 C     = NUMER FUNKCJI, 1..7
1342       IF(ARGS(NR).EQ.2)GO TO 2000
1343 C
1344 C.....JEDNOARGUMENTOWE. JEST ARGUMENT ?
1345       IF(N.EQ.0)GO TO 1500
1346       CALL SPOP
1347 C     STALA?
1348       IF(STACK(VALTOP).EQ.1)GO TO 1700
1349 C     NIE
1350       RESULT=TSTEMP(1)
1351       CALL QUADR3(OP(NR),RESULT,STACK(VALTOP-2))
1352 C ... ZASTAP CZUBEK PRZEZ WARTOSC TEJ FUNKCJI
1353  1500 STACK(VALTOP)=2
1354  1510 STACK(VALTOP-2)=RESULT
1355  1520 STACK(VALTOP-1)=0
1356       STACK(VALTOP-3)=IPMEM(IND-4)
1357       STACK(VALTOP-4)=IPMEM(IND-3)
1358       STACK(VALTOP-5)=0
1359       STACK(VALTOP-6)=0
1360       RETURN
1361 C ... STALY ARGUMENT
1362  1700 IF(NR.NE.1)GO TO 1520
1363       RESULT=NOT(STACK(VALTOP-2))
1364       GO TO 1510
1365 C
1366 C
1367 C.....DWUARGUMENTOWE. CZY SA OBA ARGUMENTY ?
1368  2000 TRESLT=IPMEM(IND-3)
1369       IF(N.EQ.2)GO TO 2200
1370 C     NIE, 1 LUB 0
1371       IF(N.EQ.1)CALL SPOP
1372       GO TO 1500
1373 C     O.K.
1374  2200 CALL SPOP
1375       CALL SARGMT
1376       IDL=STACK(VLPREV-2)
1377       IDR=STACK(VALTOP-2)
1378 C     = ATS-Y PIERWSZEGO I DRUGIEGO ARGUMENTU
1379       GO TO (2300,2400,2500,2450),ARG
1380 C ... OBA STALE
1381  2300 GO TO (2320,2320,2330,2340,2301,2301,2370),NR
1382  2301 CONTINUE
1383 C     IOR
1384  2320 RESULT=IOR(IDL,IDR)
1385       GO TO 2350
1386 C     IAND
1387  2330 RESULT=IAND(IDL,IDR)
1388       GO TO 2350
1389 C     ISHFT
1390  2340 RESULT=ISHFT(IDL,IDR)
1391 C
1392  2350 CALL SRESULT(1)
1393       RETURN
1394 C     XOR
1395  2370 RESULT=IEOR(IDL,IDR)
1396       GO TO 2350
1397 C
1398 C ... LEWY STALY,PRAWY NIE
1399  2400 IDL=SCONST(IDL)
1400  2450 RESULT=TSTEMP(1)
1401       CALL QUADR4(OP(NR),RESULT,IDL,IDR)
1402  2460 CALL SRESULT(2)
1403       RETURN
1404 C
1405 C ... PRAWY STALY,LEWY NIE
1406  2500 IF(NR.EQ.4)GO TO 2600
1407 C     IOR,IAND,XOR
1408       IDR=SCONST(IDR)
1409       GO TO 2450
1410 C ... ISHFT( .. , CONST )
1411  2600 NR=8
1412 cbc   IDR=IAND(IDR,31)
1413       IF(IDR.NE.0)GO TO 2450
1414       RESULT=IDL
1415       GO TO 2460
1416       END
1417       INTEGER FUNCTION STYPST(ELEM)
1418 C-----------------------------------------------------------------
1419 C     POMOCNICZA.
1420 C     ZWRACA /NOWY/ ATS TYPU STATYCZNEGO ELEMENTU Z MIEJSCA ELEM  STOSU
1421 C     I WSTAWIA TEN TYP
1422 C
1423 C     ##### OUTPUT CODE : 21 .
1424 C
1425 #include "stos.h"
1426 #include "blank.h"
1427 C
1428 C.....
1429       STYPST=TSTEMP(2)
1430       N=STACK(ELEM-3)
1431       K=STACK(ELEM-4)
1432       CALL QUADR4(21,STYPST,N,K)
1433       RETURN
1434       END
1435       SUBROUTINE SPHADR(ELEM)
1436 C----------------------------------------------------------------------
1437 C
1438 C     POMOCNICZA.
1439 C     GWARANTUJE,ZE PHADR ZAWIERA ADR.FIZYCZNY GENEROWANEGO OBIEKTU.
1440 C     JESLI PHADR=0,TO ODTWARZA ADR.FIZ. Z ADR.VIRT. ZE SLOWA -2 ELEMENTU
1441 C      ELEM STOSU.
1442 C
1443 C     ##### OUTPUT CODE : 47 .
1444 C
1445 C
1446 #include "stos.h"
1447 #include "blank.h"
1448 C.....
1449       IF(PHADR.NE.0)RETURN
1450 C     ZATEM TRZEBA ODTWORZYC ADRES FIZYCZNY
1451       PHADR=TSTEMP(1)
1452       CALL QUADR3(47,PHADR,STACK(ELEM-2))
1453 C     ODCZYTAJ ADR.FIZYCZNY Z VIRTUALNEGO BEZ MEMBER
1454       RETURN
1455       END
1456 C
1457       integer function sparft(ind, numdsw)
1458 C-----------------------------------------------------------------------------
1459 cdsw  dodatkowy parametr numdsw = 1 - wejscie sparft, = 2 - wejscie sparf2
1460 C
1461 C     ENTRY SPARF2
1462 C
1463 C     POMOCNICZA.
1464 C     DLA WOLANEGO MODULU /ZNANE OFFSETY/ ZWRACA  ATS ZMODYFIKOWANEGO
1465 C     TYPU FORMALNEGO PARAMETRU.
1466 C
1467 C     WEJSCIE SPARF2 : WOLANY MODUL JEST NA CZUBKU STOSU /Z SCALLE/
1468 C     WEJSCIE SPARFT : WOLANY MODUL JEST PONIZEJ CZUBKA /Z SPARAM/
1469 C
1470 C     IND - ADRES OPISU PAR. FORMALNEGO W IPMEM
1471 C
1472 C     ##### OUTPUT CODE : 54 , 85 .
1473 C
1474 #include "stos.h"
1475 #include "blank.h"
1476 C
1477       LOGICAL MLOCTP
1478 C.....
1479       ELEM=VLPREV
1480 cdsw  GO TO 1
1481 cdsw  ------------------------
1482       if(numdsw.eq.1) go to 1
1483 cdsw  ------------------------
1484 C
1485 C-----------------------
1486 cdsw  ENTRY SPARF2(IND)
1487       ELEM=VALTOP
1488     1 SPARFT=TSTEMP(2)
1489 C     CZY TEN TYP FORMALNY JEST ATRYBUTEM LOKALNYM?
1490       L=IPMEM(IND-3)
1491       IF(MLOCTP(L,STACK(ELEM-4)))GO TO 100
1492 C     NIE.ODCZYTAJ IDAC PO SL-ACH
1493       CALL QUADR4(54,SPARFT,STACK(ELEM-2),L)
1494       GO TO 200
1495 C     ATRYBUT LOKALNY
1496   100 CALL QUADR4(85,SPARFT,PHADR,IND)
1497 C.....ZMODYFIKUJ TYP
1498   200 CALL SMODIFY(SPARFT,IPMEM(IND-4))
1499 cdsw  SPARF2=SPARFT
1500       RETURN
1501       END
1502       INTEGER FUNCTION SGETPAR(IND,ELEM)
1503 C-------------------------------------------------------------------------
1504 C
1505 C     POMOCNICZA.
1506 C     ODCZYTUJE WARTOSC FUNKCJI LUB PARAMETRU OUTPUT /IND=ADRES OPISU
1507 C      W IPMEM/ I ZWRACA /NOWY/ ATS TEJ WARTOSCI.
1508 C     UZYWANA ROWNIEZ DLA ODCZYTU PAR.OUTPUT LUB WARTOSCI FUNKCJI
1509 C      DLA PROCEDUR,FUNKCJI STANDARDOWYCH.
1510 C     ELEM-MIEJSCE STOSU Z WOLANYM MODULEM
1511 C     UZYWA NRPAR,PHADR.
1512 C
1513 C     ##### OUTPUT CODE : 23 , 52 , 61 , 62 , 63 , 84 , 85 , 86 .
1514 C
1515 #include "stos.h"
1516 #include "blank.h"
1517 C
1518       INTEGER APET,K
1519 C.....
1520       APET=SAPET(IPMEM(IND-4),IPMEM(IND-3))
1521
1522 #if WSIZE == 4
1523 cvax  changed because of real appetite = 1
1524       dswap = apet
1525       if (dswap .eq. 2) dswap = 1
1526       sgetpar = tstemp(dswap)
1527 #else
1528       SGETPAR=TSTEMP(APET)
1529 #endif
1530
1531       APET=APETYT(APET)
1532 C     STANDARDOWA?
1533       IF(STACK(ELEM-4).LT.LPMSYS)GO TO 300
1534 C.....NIE
1535 C     CZY ZNANY OFFSET? TAK,JESLI W SLOWIE -3 BIT 1 =0.
1536       IF(STACK(ELEM-3).GE.16384)GO TO 200
1537 C     ZNANY OFFSET. ODCZYTAJ APET-SLOW
1538       CALL QUADR4(83+APET,SGETPAR,PHADR,IND)
1539       RETURN
1540 C     NIEZNANY OFFSET. WEZ ADRES FIZYCZNY PARAMETRU.
1541   200 K=TSTEMP(1)
1542       CALL QUADR4(52,K,PHADR,NRPAR)
1543 C     ODCZYTAJ APET-SLOW
1544       CALL QUADR3(60+APET,SGETPAR,K)
1545       RETURN
1546 C.....PROCEDURA,FUNKCJA STANDARDOWA
1547   300 APET=STACK(ELEM-4)
1548       CALL QUADR4(23,SGETPAR,IPMEM(APET+2),NRPAR)
1549       RETURN
1550       END
1551       INTEGER FUNCTION STYPFT(ELEM)
1552 C-----------------------------------------------------------------------------
1553 C
1554 C     POMOCNICZA.
1555 C     WYLICZA TYP FORMALNY ELEMENTU Z MIEJSCA ELEM STOSU /WARTOSC,ZMIENNA,
1556 C      ELEM.TABLICY,TABL.STATYCZNA,FUNKCJA/ I ZWRACA ATS TEGO TYPU.
1557 C     JESLI WB <> "(" MODYFIKUJE TEN TYP /ZWRACA ZMODYFIKOWANY/
1558 C
1559 C     ##### OUTPUT CODE : 15 , 22 , 54 , 85 .
1560 C
1561 #include "stos.h"
1562 #include "blank.h"
1563 C
1564       INTEGER N,OPKOD
1565       LOGICAL MLOCTP
1566 C.....
1567       N=STACK(ELEM)-1
1568       GO TO (200,300,200,300,199,199,199,199,199,199,300),N
1569   199 CONTINUE
1570 C
1571 C.....WARTOSC LUB ELEMENT TABLICY. TYP JUZ JEST WYLICZONY
1572   200 STYPFT=STACK(ELEM-5)
1573       GO TO 335
1574 C
1575 C.....ZMIENNA LUB TABLICA STATYCZNA. CZY PRZEZ KROPKE?
1576   300 IF(STACK(ELEM-7).EQ.0)GO TO 340
1577 C     PRZEZ KROPKE. CZY TYP FORMALNY JEST ATRYBUTEM TEGO POLA?
1578       IF(STACK(ELEM-5).LE.0)GO TO 310
1579 C     ZATEM TO ATRYBUT LOKALNY.WEZ JEGO ADR.FIZYCZNY
1580       N=SMEMBER(ELEM)
1581       OPKOD=85
1582 C     ="ODCZYTAJ 2 SLOWA"
1583       GO TO 330
1584 C     ODSZUKAJ TYP IDAC PO SL-ACH
1585   310 N=STACK(ELEM-7)
1586   320 OPKOD=54
1587 C     ="ODCZYTAJ TYP FORMALNY IDAC PO SL-ACH"
1588   330 STYPFT=TSTEMP(2)
1589       CALL QUADR4(OPKOD,STYPFT,N,STACK(ELEM-4))
1590 C
1591 C.....JESLI WB <> "(" ZMODYFIKUJ TYP
1592   335 IF(WB.NE.36)CALL SMODIFY(STYPFT,STACK(ELEM-3))
1593       RETURN
1594 C
1595 C     PRZEZ DISPLAY. CZY TYP MOZNA ODCZYTAC PRZEZ DISPLAY?
1596   340 IF(STACK(ELEM-5).GT.0)GO TO 350
1597 C     ZATEM TRZEBA ISC PO SL-ACH OD MIEJSCA DEKLARACJI ZMIENNEJ
1598 C     SLOWO -5 = - SL TEJ ZMIENNEJ
1599       N=TSTEMP(4)
1600       CALL QUADR3(15,N,-STACK(ELEM-5))
1601 C     N = ADR.VIRTUALNY POBRANY Z DISPLAYA
1602       GO TO 320
1603 C     TYP FORMALNY MOZNA ODCZYTAC POPRZEZ DISPLAY Z WARSTWY= STACK(ELEM-5)
1604   350 STYPFT=STACK(ELEM-4)
1605       OPKOD=22
1606       N=STACK(ELEM-5)
1607 C     CZY TYP JEST ATRYBUTEM LOKALNYM?
1608       IF(.NOT.MLOCTP(STYPFT,P))GO TO 330
1609 C     TAK
1610       STYPFT=TSINSE(STYPFT,2)
1611       GO TO 335
1612       END
1613       SUBROUTINE SMODIFY(N,L)
1614 C---------------------------------------------------------------
1615 C
1616 C     POMOCNICZA.
1617 C     N=ATS TYPU FORMALNEGO , L=LICZBA ARRAY OF
1618 C     MODYFIKUJE TEN TYP O WLASCIWA LICZBE ARRAY-OF I ATS WYNIKOWEGO
1619 C     TYPU PODSTAWIA NA N.
1620 C
1621 C     ##### OUTPUT CODE : 87 .
1622 C
1623       INTEGER TSTEMP
1624       IF(L.EQ.0)RETURN
1625 C     A WIEC TRZEBA MODYFIKOWAC
1626       K=TSTEMP(2)
1627       CALL QUADR4(87,K,N,L)
1628       N=K
1629       RETURN
1630       END
1631       SUBROUTINE SSTORE(ELEM,ATS)
1632 C-----------------------------------------------------------------------------
1633 C
1634 C     GENERUJE PRZESLANIE WARTOSCI O ADRESIE ATS W TABLICY SYMBOLI NA
1635 C     ELEMENT /ZMIENNA,ELEM.TABLICY,TABL.STATYCZNA/ Z MIEJSCA ELEM STOSU.
1636 C     NIE DOKONUJE ZADNEJ KONTROLI.
1637 C     NIE ZMIENIA STOSU.
1638 C     LICZBA PRZESYLANYCH SLOW ZALEZY OD TYPU WARTOSCI ELEMENTU STOSU
1639 C
1640 C     ##### OUTPUT CODE : 60 , 161 , 162 , 163 , 164 , 165 , 166 .
1641 C
1642 #include "stos.h"
1643 #include "blank.h"
1644 C
1645       INTEGER APET,ADRES,N
1646 C.....
1647       N=STACK(ELEM)-2
1648       ADRES=STACK(ELEM-2)
1649 C     WYLICZ APETYT
1650       APET=SAPET2(ELEM)
1651       APET=APETYT(APET)
1652       GO TO (300,400,500),N
1653 C
1654 C     ZMIENNA. CZY PRZEZ KROPKE?
1655   300 IF(STACK(ELEM-7).EQ.0)GO TO 350
1656 C     TAK.
1657       CALL QUADR4(163+APET,SMEMBER(ELEM),ATS,ADRES)
1658       CALL SCANCEL(ADRES)
1659       RETURN
1660 C     ZMIENNA PRZEZ DISPLAY.
1661   350 CALL QUADR3(60,ADRES,ATS)
1662 C      "MOVE"
1663       RETURN
1664 C
1665 C.....ELEM.TABLICY
1666 C     WPISZ APET-SLOW POD ADRES FIZYCZNY ELEMENTU TABLICY
1667   400 CALL QUADR3(160+APET,SARRAY(ELEM),ATS)
1668 C
1669 C     TABLICA STATYCZNA
1670   500 CONTINUE
1671 C     B R A K
1672       RETURN
1673       END
1674       INTEGER FUNCTION SARRAY(ELEM)
1675 C-----------------------------------------------------------------------------
1676 C
1677 C     POMOCNICZA.
1678 C     ZWRACA ATS ADRESU FIZYCZNEGO ELEMENTU TABLICY Z MIEJSCA ELEM STOSU
1679 C     USUWA EWENTUALNY MINUS W SLOWIE -2
1680 C
1681 C     ##### OUTPUT CODE : 64 , 65 , 102 , 103 , 104 , 105 .
1682 C
1683 #include "stos.h"
1684 #include "option.h"
1685 #include "blank.h"
1686 C
1687       INTEGER N,K
1688 C.....
1689       SARRAY=TSTEMP(1)
1690       N=SAPET2(ELEM)
1691       K=APETYT(N)
1692       N=STACK(ELEM-7)
1693 C     CZY INDEKS JEST STALA?
1694       IF(STACK(ELEM-2).LT.0)GO TO 100
1695 C.....NIE.
1696       IF(K.EQ.1)GO TO 50
1697 C     POMNOZ INDEKS PRZEZ 2 LUB 3
1698       N=TSTEMP(1)
1699       CALL QUADR3(62+K,N,STACK(ELEM-7))
1700    50 CALL QUADR4(102+OPTIND+OPTMEM,SARRAY,STACK(ELEM-2),N)
1701       RETURN
1702 C.....INDEKS JEST STALA
1703   100 N=SCONST(K*N)
1704       STACK(ELEM-2)= - STACK(ELEM-2)
1705       GO TO 50
1706       END
1707       INTEGER FUNCTION SAPET2(ELEM)
1708 C-----------------------------------------------------------------------------
1709 C
1710 C     POMOCNICZA. ZWRACA APETYT /1,3,4/ DLA STALEJ,ZMIENNEJ,WARTOSCI
1711 C     Z MIEJSCA ELEM STOSU.
1712 C
1713 #include "stos.h"
1714 #include "blank.h"
1715 C
1716       N=STACK(ELEM-3)
1717       K=STACK(ELEM-4)
1718       SAPET2=SAPET(N,K)
1719       RETURN
1720       END
1721       INTEGER FUNCTION SAPET(K,N)
1722 C-----------------------------------------------------------------------------
1723 C
1724 C     POMOCNICZA. ZWRACA APETYT/1,2,4/ DLA WARTOSCI TYPU (K,N)
1725 C                        1 - INTEGER,BOOLEAN,STRING,CHAR
1726 C                        2 - REAL
1727 C                        4 - DOWOLNY TYP REFERENCYJNY
1728 C
1729 C
1730       IMPLICIT INTEGER (A-Z)
1731 #include "blank.h"
1732 C
1733 C
1734 C     TABLICOWY?
1735       IF(K.GT.0)GO TO 100
1736 C     = 1  ?
1737       SAPET=1
1738       IF(N.EQ.NRINT)RETURN
1739       IF(N.EQ.NRBOOL)RETURN
1740       IF(N.EQ.NRCHR)RETURN
1741       IF(N.EQ.NRTEXT)RETURN
1742 C     REAL?
1743       SAPET=2
1744       IF(N.EQ.NRRE)RETURN
1745 C     REFERENCYJNY
1746   100 SAPET=4
1747       RETURN
1748       END
1749       INTEGER FUNCTION SMEMBER(ELEM)
1750 C---------------------------------------------------------------------------
1751 C
1752 C     POMOCNICZA: ZWRACA /NOWY/ ATS ADRESU FIZYCZNEGO Z ADR.VIRT. ELEMENTU
1753 C      Z MIEJSCA ELEM STOSU.
1754 C
1755 C     ##### OUTPUT CODE : 46 , 47  .
1756 C
1757 #include "stos.h"
1758 #include "option.h"
1759 #include "blank.h"
1760 C
1761 C
1762       SMEMBER=TSTEMP(1)
1763       N=STACK(ELEM-7)
1764       CALL QUADR3(46+OPTMEM,SMEMBER,N)
1765       RETURN
1766       END
1767       INTEGER FUNCTION SPRFLD(PARAM)
1768 C----------------------------------------------------------------------------
1769 C
1770 C     ZWRACA /NOWY/ATS NUMERU PROTOTYPU LUB OJCA SYNT. I NUMERU PROTOTYPU.
1771 C     PARAM=.TRUE. -UZYWANE PRZY PRZEKAZYWANIU PARAMETRU AKTUALNEGO
1772 C               /NA CZUBKU NA PEWNO FUNKCJA,PROCEDURA/
1773 C            DOSTARCZA OJCA SYNTAKTYCZNEGO I PROTOTYPU/SKLEJONE W 1 ARG./
1774 C            WOLANA PRZEZ SPARAM.
1775 C     PARAM=.FALSE. -UZYWANE PRZY GENEROWANIU OBIEKTU KLASY,PROCEDURY,FUNKCJI
1776 C            LUB BLOKU PREF. DOSTARCZA NUMERU PROTOTYPU /DLA PARAMETRU LUB
1777 C            DOSTEPU PRZEZ KROPKE-ROWNIEZ OJCA SYNT./.
1778 C            CZUBEK STOSU ZAWIERA KLASE,BLOK PREF,PROCEDURE,FUNKCJE.
1779 C            WOLANA PRZEZ SCALLB.
1780 C
1781 C     NIE UZYWANA DLA PROCEDUR,FUNKCJI STANDARDOWYCH.
1782 C
1783 C     ##### OUTPUT CODE : 15 , 16, 20 , 44 , 45 , 86 , 112 .
1784 C
1785 C
1786 #include "stos.h"
1787 #include "option.h"
1788 #include "blank.h"
1789 CCCCCCCCCCCCCCCC
1790       LOGICAL PARAM
1791 C
1792       INTEGER OPKOD,IND,ATS,N
1793 C
1794 C.................
1795       SPRFLD=TSTEMP(1)
1796       IND=STACK(VALTOP-4)
1797 C     IND=ADRES PROTOTYPU
1798 C.....CZY TO PARAMETR,VIRTUAL CZY "ZWYKLY" PROTOTYP?
1799       N=KIND+1
1800       GO TO (100,200,300),N
1801 C.....ZWYKLY PROTOTYP.WSTAW JEGO NUMER.
1802   100 CALL QUADR3(16,SPRFLD,STACK(VALTOP-4))
1803 C     DLA BLOKU PREF. TO JUZ WSZYSTKO
1804       IF(STACK(VALTOP).EQ.10)RETURN
1805 C     CZY PRZEZ KROPKE?
1806       IF(STACK(VALTOP-7).EQ.0)GO TO 150
1807 C     TAK.
1808   125 ATS=STACK(VALTOP-7)
1809 C.....SKLEJ ADRES VIRTUALNY /ATS/ I NUMER PROTOTYPU /SPRFLD/ W 1 ARGUMENT.
1810   130 OPKOD=112
1811 C     OPKOD="SKLEJ W 1 ARG."
1812       N=SPRFLD
1813   135 SPRFLD=TSTEMP(3)
1814       CALL QUADR4(OPKOD,SPRFLD,ATS,N)
1815       RETURN
1816 C.....ZWYKLY PROTOTYP NIE PRZEZ KROPKE.JESLI NIE PARAMETR-KONIEC.
1817   150 IF(.NOT.PARAM)RETURN
1818 C     ZATEM PARAMETR.WEZ ADRES Z DISPLAYA.
1819       ATS=TSTEMP(4)
1820       CALL QUADR3(15,ATS,IPMEM(IND-1))
1821       GO TO 130
1822 C.....PROCEDURA,FUNKCJA VIRTUALNA.
1823   200 IF(STACK(VALTOP-7).EQ.0)GO TO 250
1824 C     WYZNACZ PRZEZ KROPKE PROTOTYP VIRTUALA
1825 cbc split opcode 44,45 into 228 (LASKPROT) and 44,45 (LVIRTDOT)
1826 cbc in order to call virtual from process properly
1827 cbc   CALL QUADR4(44+OPTMEM,SPRFLD,STACK(VALTOP-7),IPMEM(IND+27))
1828       call quadr2(228, stack(valtop-7))
1829       call quadr3(44+optmem, sprfld, ipmem(ind+27))
1830 cbc
1831       GO TO 125
1832 C     WYZNACZ PRZEZ DISPLAY PROTOTYP VIRTUALA
1833   250 CALL QUADR4(20,SPRFLD,IPMEM(IND-1),IPMEM(IND+27))
1834       GO TO 150
1835 C.....PARAMETR. ODCZYTAJ
1836   300 IF(STACK(VALTOP-7).EQ.0)GO TO 350
1837 C     A WIEC PRZEZ KROPKE.WEZ ADRES FIZYCZNY POLA.
1838       ATS=SMEMBER(VALTOP)
1839       N=IND
1840       OPKOD=86
1841 C     OPKOD="WCZYTAJ 3 SLOWA Z POLA O ADR.FIZYCZNYM..."
1842 C     ATS=ADR.FIZYCZNY,SPRFLD=ATS PARAMETRU
1843       GO TO 135
1844 C     PARAMETR PRZEZ DISPLAY
1845   350 SPRFLD=TSINSE(IND,LOCAL)
1846       RETURN
1847       END
1848       INTEGER FUNCTION SFPRST(N)
1849 C----------------------------------------------------
1850 C
1851 C     POMOCNICZA. N=NUMER PARAMETRU. ODCZYTUJE TYP
1852 C     /NIEZNANY W CZASIE KOMPILACJI/ N-TEGO PARAMETRU
1853 C     PROCEDURY,FUNKCJI VIRTUALNEJ LUB FORMALNEJ,ZWRACA JEGO ATS.
1854 C
1855 C     ##### OUTPUT CODE : 40 .
1856 C
1857 #include "stos.h"
1858 C
1859 C
1860 C
1861       SFPRST=TSTEMP(2)
1862       CALL QUADR4(40,SFPRST,PHADR,N)
1863       RETURN
1864       END
1865       INTEGER FUNCTION SPARST(N)
1866 C-----------------------------------------------------------------------
1867 C
1868 C     POMOCNICZA.WSTAWIA TYP STATYCZNY PARAMETRU FORMALNEGO.
1869 C     N=ADRES OPISU PARAMETRU W IPMEM
1870 C
1871 C     ##### OUTPUT CODE : 21 .
1872 C
1873       IMPLICIT INTEGER (A-Z)
1874 #include "blank.h"
1875 C
1876 C
1877       SPARST=TSTEMP(2)
1878       CALL QUADR4(21,SPARST,IPMEM(N-4),IPMEM(N-3))
1879       RETURN
1880       END
1881       SUBROUTINE SAFE(N)
1882 C---------------------------------------------------------------------
1883 C
1884 C     N = ADRES W TABLICY SYMBOLI LUB 0.
1885 C     JESLI N <> 0 ,GENERUJE NOWY ATRYBUT ROBOCZY I ZASTEPUJE NIM
1886 C      PARAMETR AKTUALNY,ZACHOWUJAC ZNAK.
1887 C     GENERUJE OPKOD MOVE&SAFE - NOWY ATRYBUT Z WARTOSCIA I APETYTEM
1888 C     STAREGO,WARTOSC W ZMIENNEJ ROBOCZEJ.
1889 C
1890 C     ##### OUTPUT CODE : 195 .
1891 C
1892 #include "stos.h"
1893 #include "blank.h"
1894 C
1895 C
1896       IF(N.EQ.0)RETURN
1897       LSTEMP=LSTEMP-3
1898       K=LSTEMP
1899 C     ABY ZACHOWAC EWENTUALNY MINUS
1900       IF(N.GT.0) GO TO 100
1901       K= - K
1902       N= - N
1903   100 CALL QUADR3(195,LSTEMP,N)
1904       N=K
1905       RETURN
1906       END
1907       INTEGER FUNCTION TSTEMP(N)
1908 C------------------------------------------------------------------------
1909 C
1910 C
1911 C     ##### OUTPUT CODE : 201 , 202 , 203 , 204 .
1912 C
1913 #include "stos.h"
1914 #include "blank.h"
1915 C
1916 C
1917       LSTEMP=LSTEMP-3
1918       TSTEMP=LSTEMP
1919       CALL QUADR2(200+N,TSTEMP)
1920       IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
1921       RETURN
1922       END
1923       INTEGER FUNCTION TSINSE(K,N)
1924 C-------------------------------------------------------------------------
1925 C
1926 C     K = ADRES OPISU ATRYBUTU W IPMEM
1927 C     N = WIDZIALNOSC : 0 - GLOBALNY,1 - PRZEZ DISPLAY,2 - LOKALNY ATRYBUT
1928 C
1929 C     WYZNACZA ADRES OPISU ATRYBUTU W TABLICY SYMBOLI.
1930 C     UZYWA POMOCNICZEGO SLOWNIKA ZAWIERAJACEGO TYLKO ATRYBUTY UZYTE
1931 C     W BIEZACYM MODULE.
1932 C
1933 C     ELEMENTY SLOWNIKA:
1934 C             SLOWO  0 = P /BIEZACY PROTOTYP/    ORAZ
1935 C             SLOWO +1 = ADRES OPISU ATRYBUTU W IPMEM
1936 C                         <=> ATRYBUT JEST W SLOWNIKU.
1937 C                                           - I WTEDY SLOWO +1 OPISU
1938 C                            ATRYBUTU ZAWIERA ADRES TEGO ELEMENTU SLOWNIKA
1939 C
1940 C             SLOWO +2 = ADRES W TABLICY SYMBOLI
1941 C
1942 C             JESLI SLOWO 0  <> P LUB SLOWO +1  <> ADRESU ATRYBUTU
1943 C                TO ATRYBUTU JESZCZE NIE MA W SLOWNIKU
1944 C     ELEMENTY SLOWNIKA DOPISYWANE SA NA LEWO OD LMEM
1945 C       IPMEM(LMEM) = INDEKS PIERWSZEGO OD PRAWEJ WOLNEGO
1946 C
1947 C
1948 C
1949 C     ##### OUTPUT CODE : 205 , 206 , 207 .
1950 C
1951 C     ##### DETECTED ERROR(S) : 553 , 554 . ( PRZEPELNIENIA )
1952 C
1953 C
1954 #include "stos.h"
1955 #include "blank.h"
1956 C
1957 C
1958 C
1959 C
1960       TSINSE=IPMEM(K+1)
1961 C     UZYTY JUZ W TYM MODULE?
1962       IF(IPMEM(TSINSE).NE.P)GO TO 100
1963       IF(IPMEM(TSINSE+1).NE.K)GO TO 100
1964 C.....TAK.
1965       TSINSE=IPMEM(TSINSE+2)
1966       RETURN
1967 C.....JESZCZE NIE. WYZNACZ NOWY ADRES W TABLICY SYMBOLI
1968   100 J=IPMEM(LMEM)-3
1969       IF(IRECN.GT.J)GO TO 200
1970       IPMEM(LMEM)=J
1971       TSINSE=J+1
1972       IPMEM(TSINSE)=P
1973       IPMEM(TSINSE+1)=K
1974       IPMEM(TSINSE+2)=FRSTTS
1975       IPMEM(K+1)=TSINSE
1976       TSINSE=FRSTTS
1977       FRSTTS=FRSTTS+3
1978       CALL QUADR3(205+N,TSINSE,K)
1979       IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
1980       RETURN
1981 C.....PRZEPELNIENIE TABLICY SYMBOLI LUB SLOWNIKA STALYCH REAL
1982   200 CALL SERRO2(504,0)
1983       RETURN
1984       END
1985       SUBROUTINE SCANCEL(ADR)
1986 C-----------------------------------------------------------------------------
1987 C
1988 C     JESLI ATRYBUT WSKAZANY PRZEZ ADR BYL UZYTY /JEST W TABLICY
1989 C       SYMBOLI/  - PROCEDURA WYPISUJE OPKOD "CANCEL"  , INACZEJ
1990 C      NIC NIE ROBI.
1991 C
1992 C     UZYWANA PRZY ZMIANIE WARTOSCI ATRYBUTU DOSTEPNEGO PRZEZ KROPKE,
1993 C      DLA ZABEZPIECZENIA NASTEPNEGO PRZEBIEGU PRZED TRZYMANIEM
1994 C       INFORMACJI "WARTOSC ATRYBUTU W REJESTRZE" POMIMO /NIEJAWNEJ/
1995 C       ZMIANY WARTOSCI TEGO ATRYBUTU PRZY UZYCIU DOSTEPU KROPKOWANEGO.
1996 C
1997 C     ##### OUTPUT CODE : 158 .
1998 C
1999 C
2000       IMPLICIT INTEGER (A-Z)
2001 #include "blank.h"
2002 C
2003 C
2004 C
2005 C.....JEST W TABLICY SYMBOLI?
2006       N=IPMEM(ADR+1)
2007       IF(IPMEM(N).NE.P)RETURN
2008       IF(IPMEM(N+1).NE.ADR)RETURN
2009 C     TAK
2010       CALL QUADR2(158,IPMEM(N+2))
2011       RETURN
2012       END
2013       SUBROUTINE SAFEST
2014 C-------------------------------------------------------------------------
2015 C
2016 C     ZABEZPIECZA ELEMENTY STOSU PRZY GENERACJI NOWEGO MODULU:
2017 C     DLA ELEMENTOW BEDACYCH LSE ZABEZPIECZA ADRES TJ. WARTOSC WYRAZENIA
2018 C     PRZED KROPKA DLA ZMIENNEJ I TABLICY STATYCZNEJ, ADRES TABLICY DLA
2019 C     ELEMENTU TABLICY I WARTOSC INDEKSU - JESLI NIE STALA - DLA TABLIC.
2020 C
2021 C     DLA ELEMENTOW POWYZEJ LSTLSE ZABEZPIECZA WARTOSC ZMIENNYCH.
2022 C
2023 C     ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
2024 C
2025 #include "stos.h"
2026 #include "blank.h"
2027 C
2028 C
2029       INTEGER K,ELEM,N,L
2030 C......ZACZNIJ OD POPRZEDNIEGO
2031       K=VLPREV
2032 C     CZY JEST COS NIEZABEZPIECZONEGO NAD OPISAMI PETLI FOR?
2033   100 IF(K.GT.LSTFOR .AND. K.GT.LSTSAF)GO TO 120
2034 C     NIE
2035       LSTSAF=VLPREV
2036       RETURN
2037 C     TAK.
2038   120 ELEM=STACK(K)
2039 C     ELEM=RODZAJ ELEMENTU
2040       IF(ELEM.LT.2 .OR. ELEM.GT.5)GO TO 1000
2041 C     LSE?
2042       IF(K.LE.LSTLSE)GO TO 200
2043 C.....A WIEC POWYZEJ LSE : WARTOSC,ZMIENNA,ELEM.TABLICY,TABLICA STATYCZNA.
2044 C     ZASTAP PRZEZ WARTOSC.
2045       IF(ELEM.EQ.2)GO TO 150
2046       IF(ELEM.EQ.4)GO TO 160
2047 C     B R A K   DLA TABLICY STATYCZNEJ
2048 C ... ZMIENNA. PRZEZ KROPKE?
2049       IF(STACK(K-7).EQ.0)GO TO 140
2050 C     TAK.ODCZYTAJ WARTOSC
2051       N=SAPET2(K)
2052 C     N=RODZAJ APETYTU ZMIENNEJ
2053 #if WSIZE == 4
2054 cvax changed because of real appetite = 1
2055       dswap = n
2056       if (dswap .eq.2) dswap = 1
2057       l = tstemp(dswap)
2058 #else
2059       L=TSTEMP(N)
2060 #endif
2061
2062       N=APETYT(N)
2063       CALL QUADR4(83+N,L,SMEMBER(K),STACK(K-2))
2064   135 STACK(K-2)=L
2065 C     WPISZ 'WARTOSC'
2066   140 STACK(K)=2
2067   150 CALL SAFE(STACK(K-2))
2068       GO TO 1000
2069 C ... ELEM.TABLICY.  ODCZYTAJ WARTOSC
2070   160 N=SAPET2(K)
2071 #if WSIZE == 4
2072 cvax changed because of real appetite = 1
2073       dswap = n
2074       if (dswap .eq.2) dswap = 1
2075       l = tstemp(dswap)
2076 #else
2077       L=TSTEMP(N)
2078 #endif
2079
2080       N=APETYT(N)
2081       CALL QUADR3(60+N,L,SARRAY(K))
2082       GO TO 135
2083 C.....LSE : ZMIENNA,ELEM.TABLICY,TABLICA STATYCZNA.
2084   200 CALL SAVEVAR(K)
2085 C
2086 C.....WEZ POPRZEDNI ELEMENT
2087  1000 K=K-STCKAP(ELEM)
2088       GO TO 100
2089       END
2090       SUBROUTINE SINDXS
2091 C      MAKIETA
2092       RETURN
2093       END
2094       SUBROUTINE QUADR4(N1,N2,N3,N4)
2095 C------------------------------------------------------------
2096 C
2097 C     WYPISUJE GENEROWANY KOD POSREDNI
2098 C
2099 #include "stos.h"
2100 #include "blank.h"
2101 C
2102 C
2103       COMMON/TEST/TESTC,TESTS,TESTH
2104       LOGICAL TESTC,TESTS,TESTH
2105       common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2106 C
2107 C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2108
2109       IPMEM(LSTWRD+1)=N1
2110       IPMEM(LSTWRD+2)=N2
2111       IPMEM(LSTWRD+3)=N3
2112       IPMEM(LSTWRD+4)=N4
2113
2114       IF(.NOT.TESTC) GOTO 1000
2115       call ffputcs(13,' *******************')
2116       call ffputi (13,N1,8)
2117       call ffputi (13,N2,8)
2118       call ffputi (13,N3,8)
2119       call ffputi (13,N4,8)
2120       call ffputnl(13)
2121 1000  CONTINUE
2122
2123       LSTWRD=LSTWRD+4
2124       IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2125       RETURN
2126       END
2127       SUBROUTINE QUADR3(N1,N2,N3)
2128 C------------------------------------------------------------
2129 C
2130 C     WYPISUJE GENEROWANY KOD POSREDNI
2131 C
2132 C
2133 #include "stos.h"
2134 #include "blank.h"
2135 C
2136       COMMON/TEST/TESTC,TESTS,TESTH
2137       LOGICAL TESTC,TESTS,TESTH
2138       common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2139 C
2140 C
2141 C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2142       IPMEM(LSTWRD+1)=N1
2143       IPMEM(LSTWRD+2)=N2
2144       IPMEM(LSTWRD+3)=N3
2145
2146       IF(.NOT.TESTC) GOTO 1000
2147       call ffputcs(13,' *******************')
2148       call ffputi (13,N1,8)
2149       call ffputi (13,N2,8)
2150       call ffputi (13,N3,8)
2151       call ffputnl(13)
2152 1000  CONTINUE
2153
2154       LSTWRD=LSTWRD+3
2155       IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2156       RETURN
2157       END
2158       SUBROUTINE QUADR2(N1,N2)
2159 C------------------------------------------------------------
2160 C
2161 C     WYPISUJE GENEROWANY KOD POSREDNI
2162 C
2163 #include "stos.h"
2164 #include "blank.h"
2165 C
2166 C
2167       COMMON/TEST/TESTC,TESTS,TESTH
2168       LOGICAL TESTC,TESTS,TESTH
2169       common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2170 C
2171 C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2172       IPMEM(LSTWRD+1)=N1
2173       IPMEM(LSTWRD+2)=N2
2174
2175       IF(.NOT.TESTC) GOTO 1000
2176       call ffputcs(13,' *******************')
2177       call ffputi (13,N1,8)
2178       call ffputi (13,N2,8)
2179       call ffputnl(13)
2180 1000  CONTINUE
2181
2182       LSTWRD=LSTWRD+2
2183       IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2184       RETURN
2185       END
2186       SUBROUTINE QUADR1(N1)
2187 C------------------------------------------------------------
2188 C
2189 C     WYPISUJE GENEROWANY KOD POSREDNI
2190 C
2191 #include "stos.h"
2192 #include "blank.h"
2193 C
2194 C
2195       COMMON/TEST/TESTC,TESTS,TESTH
2196       LOGICAL TESTC,TESTS,TESTH
2197       common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2198 C
2199 C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2200       LSTWRD=LSTWRD+1
2201       IPMEM(LSTWRD)=N1
2202
2203       IF(.NOT.TESTC) GOTO 1000
2204       call ffputcs(13,' *******************')
2205       call ffputi (13,N1,8)
2206       call ffputnl(13)
2207 1000  CONTINUE
2208
2209       IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2210       RETURN
2211       END
2212       SUBROUTINE QDROUT
2213 C-----------------------------------------------------------------------------
2214 C
2215 C     OPROZNIA BUFOR IPMEM Z GENEROWANYM KODEM POSREDNIM.
2216 C     PRZEPISUJE OSTATNIE 3 LICZBY NA POCZATEK,USTAWIA LSTWRD.
2217 C     JESLI ERRFLG=.TRUE. - NIE WYPISUJE NIC.
2218 C
2219 #include "stos.h"
2220 #include "blank.h"
2221 C
2222 C
2223 C     BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2224       COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
2225       LOGICAL ERRFLG
2226 C
2227 C.....
2228       IF(ERRFLG)GO TO 100
2229 C     WEZ NOWY NUMER REKORDU
2230       call ffwrite_ints(18, ipmem(lmem-259), 256)
2231
2232 cbc
2233 cdsw *********************************
2234 C     PRZEPISZ OSTATNIE 3 SLOWA NA POCZATEK
2235       N=LMEM-259
2236       M=LMEM-3
2237       IPMEM(N)=IPMEM(M)
2238       IPMEM(N+1)=IPMEM(M+1)
2239       IPMEM(N+2)=IPMEM(M+2)
2240   100 LSTWRD=LSTWRD-256
2241       RETURN
2242       END
2243       SUBROUTINE SERROR(NUMER)
2244 C------------------------------------------------------------------------
2245 cdsw procedura podzielona na serror i serro2
2246 C
2247 C     SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
2248 C     DLA 'UNIWERSALNEGO' NIE ROBI NIC.
2249 C
2250 C
2251 C     ENTRY SERRO2
2252 C
2253 C
2254 #include "stos.h"
2255 #include "blank.h"
2256 C
2257 C
2258       COMMON/TEST/TESTC,TESTS,TESTH
2259       LOGICAL TESTC,TESTS,TESTH
2260 C
2261 C
2262       ELEM=VALTOP
2263   100 IF(STACK(ELEM).EQ.0)RETURN
2264       NAZWA=STACK(ELEM-1)
2265
2266       IF(.NOT.TESTC) GOTO 1000
2267       call ffputcs(13,' ERROR')
2268       call ffputi (13,NUMER,6)
2269       call ffputi (13,NAZWA,8)
2270       call ffputnl(13)
2271 1000  CONTINUE
2272
2273       CALL MERR(NUMER,NAZWA)
2274       RETURN
2275       END
2276       SUBROUTINE SERRO2(NUMER,elem)
2277 C------------------------------------------------------------------------
2278 cdsw procedura podzielona na serror i serro2
2279 C
2280 C     SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
2281 C     DLA 'UNIWERSALNEGO' NIE ROBI NIC.
2282 C
2283 C
2284 C     ENTRY SERRO2
2285 C
2286 C
2287 #include "stos.h"
2288 #include "blank.h"
2289 C
2290 C
2291       COMMON/TEST/TESTC,TESTS,TESTH
2292       LOGICAL TESTC,TESTS,TESTH
2293 C
2294 C
2295   100 IF(STACK(ELEM).EQ.0)RETURN
2296       NAZWA=STACK(ELEM-1)
2297
2298       IF(.NOT.TESTC) GOTO 1000
2299       call ffputcs(13,' ERROR')
2300       call ffputi (13,NUMER,6)
2301       call ffputi (13,NAZWA,8)
2302       call ffputnl(13)
2303 1000  CONTINUE
2304
2305       CALL MERR(NUMER,NAZWA)
2306       RETURN
2307       END
2308       SUBROUTINE SSTOVF
2309 C---------------------------------------------------------------------------
2310 C
2311 C     SYGNALIZUJE PRZEPELNIENIE TABLICY SYMBOLI - BLAD 553
2312 C      I CZYSCI JA
2313 C
2314 C
2315 #include "stos.h"
2316 #include "blank.h"
2317 cdsw&bc
2318       common /stacks/ btsins, btstem
2319 C
2320 C
2321 C
2322 C
2323 C....PRZEPELNIENIE TABLICY SYMBOLI
2324       CALL MERR(553,0)
2325 C     OPROZNIJ TABLICE SYMBOLI
2326 cdsw&bc      FRSTTS=LPMEM+1
2327 c            TEMPNR=LMEM-3
2328       frstts = btsins
2329       tempnr = btstem-3
2330 c
2331 cdsw  ----------  added  -----------
2332       lstemp = tempnr
2333 cdsw  ------------------------------
2334       IPMEM(LMEM)=BOTTOM-1
2335       RETURN
2336       END
2337
2338
2339       SUBROUTINE STEST
2340 C---------------------------------------------------------------------
2341 C
2342 C     READ TESTING OPTIONS
2343 #include "stos.h"
2344 C
2345 C
2346       COMMON/TEST/TESTC,TESTS,TESTH
2347       LOGICAL TESTC,TESTS,TESTH
2348 C
2349 cdsw  BYTE  CHARS(80)
2350 cdsw  BYTE  HN,HNS,HY,HYS,HC,HS,HH
2351 cdsw  ---------------------------------
2352       character chars(80)
2353       character hn,hns,hy,hys,hc,hs,hh
2354 cdsw  ---------------------------------
2355       DATA HN,HNS,HY,HYS,HC,HS,HH /'n','n','y','y','c','s','h'/
2356 C
2357 C
2358       TEST=.FALSE.
2359       TESTC=.FALSE.
2360       TESTS=.FALSE.
2361       TESTH=.FALSE.
2362       ATLINE=0
2363       RETURN
2364
2365 100   call ffputcs(0,' TESTING ?   Y/N:')
2366       call ffgets (0,CHARS,80)
2367
2368       IF(CHARS(1).EQ.HN .OR. CHARS(1).EQ.HNS)RETURN
2369       IF(CHARS(1).NE.HY .AND. CHARS(1).NE.HYS) GO TO 100
2370       TEST=.TRUE.
2371
2372       call ffputcs(0,' OPTIONS : C - code , S - stack , H - halt')
2373       call ffputnl(0)
2374
2375       call ffgets (0,CHARS,80)
2376
2377       DO 200 N=1,80
2378       IF(CHARS(N).EQ.HC)TESTC=.TRUE.
2379       IF(CHARS(N).EQ.HS)TESTS=.TRUE.
2380       IF(CHARS(N).EQ.HH)TESTH=.TRUE.
2381   200 CONTINUE
2382 cdsw  IF(TESTH) CALL STOPAT
2383       RETURN
2384       END
2385       SUBROUTINE SABORT
2386       RETURN
2387       END
2388       SUBROUTINE SRCVOFF
2389       RETURN
2390       END
2391
2392
2393       SUBROUTINE SLCSTOUT
2394 C---------------------------------------------------------------------
2395 C
2396 C     WYPISUJE NA PLIK 15 HEKSADECYMALNA REPREZENTACJE
2397 C     TABLICY SYMBOLI I L-KODU.
2398 C
2399 #include "stos.h"
2400 #include "blank.h"
2401 C
2402 C
2403       COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
2404       LOGICAL ERRFLG
2405 C     IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
2406 C
2407 C
2408       INTEGER BL(302)
2409       EQUIVALENCE ( BL(1),IOP(1) )
2410
2411       integer*4 offset
2412       integer*2 bigbuf
2413       integer buf1(1)
2414       common /combuf/ ind, length, bigbuf(16000)
2415 cvax  equivalence (bigbuf(1), buf1(1))
2416       character bufc(32000)
2417       equivalence (bigbuf(1), buf1(1), bufc(1))
2418
2419 cdsw&ail
2420       common /stacks/ btsins, btstem
2421
2422 cbc
2423 C
2424 C.....SYMBOL TABLE
2425 cdsw&ail
2426 c  adres stalej none jest przekazany na zmiennej LOCAL ( numer 300 )
2427       LOCAL = btstem-3
2428       call ffwrite_ints(15, bl(1), 302)
2429 #if WSIZE == 4
2430 CPS   tu bylo porownanie z 50000, co dla LPMEM=48000 dalo maximun
2431 CPS   2000 slow na stale rzeczywiste - nie rozumiem skad to ograniczenie
2432 CPS   dlatego nie zmienilem go
2433       if (irecn .gt. LPMEMSIZE+2000 ) call mdrop(0)
2434 #endif
2435       call ffwrite_ints(15, ipmem(1), irecn)
2436 C.....L-CODE
2437       offset=0
2438       call ffseek(18,offset)
2439 3000  len=31744
2440       call ffread(18,buf1(1),len)
2441       if (len .eq. 0) goto 3010
2442       wlen = len
2443       call ffwrite(15,buf1(1),wlen)
2444       if (len .eq. 31744) goto 3000
2445 3010  continue
2446       RETURN
2447       END
2448