1 C Loglan82 Compiler&Interpreter
2 C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
3 C Copyright (C) 1993, 1994 LITA, Pau
5 C This program is free software; you can redistribute it and/or modify
6 C it under the terms of the GNU General Public License as published by
7 C the Free Software Foundation; either version 2 of the License, or
8 C (at your option) any later version.
10 C This program is distributed in the hope that it will be useful,
11 C but WITHOUT ANY WARRANTY; without even the implied warranty of
12 C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 C GNU General Public License for more details. File: LICENSE.GNU
14 C ===============================================================
17 C-----------------------------------------------------------------------------
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.
27 C UZYWANA ROWNIEZ DLA PROCEDUR I FUNKCJI STANDARDOWYCH.
28 C / TYLKO PARAMETRY INPUT, OUTPUT, IN-OUT / .
31 C KOLEJNOSC OBSLUGI PARAMETRU :
32 C 1) WOLA MPKIND OKRESLAJACE RODZAJ PARAMETRU :
40 C I PRZYPISUJE PARAM ADRES OPISU PAR.FORMALNEGO W IPMEM
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/
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.
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/
61 C DLA PAR. TYPE : WOLA MPARTP / ZAWSZE! ,DLA PAR.AKT. NIEPOPRAWNEGO
62 C LUB UNIWERSALNEGO PODAJE NRUNIV/ I WPISUJE TYP DO POLA DANYCH
64 C DLA PAR. FUNCTION,PROCEDURE : WOLA MPARPF ,
65 C USTAWIA KIND , WOLA SPRFLD /GENERUJACA PROTOTYP
67 C WPISUJE PROTOTYP I OTOCZENIE PAR.AKTUALNEGO DO POLA DANYCH,
68 C EW. GENERUJE DYNAMICZNA KONTROLE ZGODNOSCI NAGLOWKOW.
70 C DLA PAR. IN-OUT : NAJPIERW OBSLUGUJE GO JAK PAR. OUTPUT,
71 C A NASTEPNIE JAK PAR.INPUT
73 C UZYWA: PHADR , NRPAR
76 C # OUTPUT CODE : 43 , 52 , 144 , 150 , 161 , 162 , 163 ,
77 C 164 , 165 , 166 , 170 .
79 C ##### DETECTED ERROR(S) : 470 , 471 , 472 , 473 , 474 , 478 , 550 .
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
95 DATA SPARAHEX /x'0800'/
96 C =.TRUE. JESLI KONIECZNA DYNAMICZNA KONTROLA NAGLOWKOW PROC.,FUNC.
100 C RODZAJ PAR.AKTUALNEGO ?
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
110 C- - - - - - - - - - PAR. I N - O U T - - - - - - -
112 C ZMIEN KWALIFIKACJE NA INPUT /KOD ODCZYTUJACY WARTOSC JUZ WYGENEROWANY/
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
124 C PRZECHOWAJ NUMER PARAMETRU: NA CZUBKU MOZE BYC FUNKCJA BEZPARAMETROWA,
125 C ODCZYT JEJ WARTOSCI MOZE ZNISZCZYC NRPAR
128 C SPRAWDZ ZGODNOSC TYPOW
129 CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
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)
135 C ATS WARTOSCI PARAMETRU
136 C.....FUNKCJA,PROCEDURA STANDARDOWA ?
137 IF(STACK(VLPREV-4).LT.LPMSYS)GO TO 1800
140 C CZY PAR.AKTUALNY JEST STALA?
141 IF(ELEM.EQ.1)GO TO (1007,1008,9905,9905),APET
143 C PARAMETR NIE JEST STALA
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
155 C ... APETYT 2 ( REAL - TYP FORMALNY TU NIE WYSTAPI )
156 cdsw&bc 1008 IF(STALER(ATS).EQ. 0.0)GO TO 9905
159 C WSTAW STALA REAL, SKOCZ DO WPISANIA WARTOSCI
164 C.....JESLI NIEPOTRZEBNA KONTROLA DYNAMICZNA - WPISZ WARTOSC
165 1050 IF(CONTRL.LT.3 .OR. OPTTYP)GO TO 9750
169 C IDR = ZMODYFIKOWANY TYP FORMALNY PARAMETRU AKTUALNEGO LUB ZERO
171 C CZY ZNANY OFFSET? /NIE,JESLI TO VIRTUAL LUB PARAMETR/
172 IF(STACK(VLPREV-3).GE.16384)GO TO 1500
175 C.....ZNANY OFFSET PARAMETRU.
177 GO TO(1100,1200,1300,1400),CONTRL
178 C.....KONTROLA DYNAMICZNA, OBA TYPY ZNANE
179 1100 CALL QUADR3(150,ATS,IPMEM(PARAM-3))
181 C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST FORMALNY,AKTUALNEGO ZNANY
182 1200 IDR=STYPST(VALTOP)
184 C.....KONTROLA DYN.,TYP PAR.FORMALNEGO JEST ZNANY,AKTUALNEGO FORMALNY
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)
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)
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 /
212 STACK(IDR)=STACK(IDL)
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
223 C-------------------- PAR. O U T P U T ---------------
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
230 C O.K. SPRAWDZ ZGODNOSC TYPOW
231 2005 CONTRL=MPARIO(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-1),
233 C ZABEZPIECZ ADRES ZMIENNEJ
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.
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
249 C SLOWO -1 ZAMIAST NAZWY ZAWIERA ADRES W IPMEM OPISU PARAMETRU
251 C SLOWO +1 = NUMER PARAMETRU /NRPAR/
252 C SLOWO 0 W BITACH 9-11 INFORMACJE O KONTROLI /MPARIO(..)/
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
264 2115 STACK(CONTRL)=STACK(APET)
267 IF(CONTRL.GT.FSTOUT-12)GO TO 2115
268 C SLOWA VALTOP-0,..,VALTOP-9 PRZEPISANE NA MIEJSCA FSTOUT-2,..,FSTOUT-11.
274 C-------------------- PAR. T Y P E ---------------------
276 C CZY PAR.AKTUALNY TO NAZWA TYPU,REKORD,KLASA?
277 3000 IF(ELEM.LT.7 .OR. ELEM.GT.9)GO TO 3800
279 CALL MPARTP(STACK(VALTOP-3),STACK(VALTOP-4),STACK(VALTOP-6),
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)
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
295 C------------- PAR. F U N C T I O N , P R O C E D U R E ------
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
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
311 4020 CALL MPARPF(APET,STACK(VALTOP-1),STACK(VALTOP-6),DCONTR)
314 C WEZ ZEROWE SLOWO OPISU
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
328 C-------------------------------
331 C.....WSPOLNA SYGNALIZACJA BLEDU.
333 9600 CALL SERROR(PARAM)
337 C.....WPISANIE WARTOSCI PARAMETRU Z NIEZNANYM OFFSETEM
338 9700 CONTRL=TSTEMP(1)
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)
346 C.....WPISANIE WARTOSCI. CZY ZNANY OFFSET?
347 9750 IF(STACK(VLPREV-3).GE.16384)GO TO 9700
349 C.....WPISANIE WARTOSCI PARAMETRU ZE ZNANYM OFFSETEM
352 CALL QUADR4(163+APET,PHADR,ATS,PARAM)
353 C WPISZ APET-SLOW DO POLA WSKAZANEGO PRZEZ ADRES FIZYCZNY PHADR
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
361 CALL QUADR3(43,APET,STACK(VLPREV-2))
363 CALL QUADR3(144,APET,NRPAR)
367 C ... JESLI TO IN-OUT ,TO POTRAKTUJ GO TERAZ JAK INPUT
368 9905 IF(PARKIND.EQ.7)GO TO 990
374 C-----------------------------------------------------------------------------
375 cdsw procedura podzielona na svalue i svalue2 - entry usuniete
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.
388 C WEJSCIE SVALUE - DLA CZUBKA STOSU
389 C WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
391 C ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
393 C ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
399 C NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
401 INTEGER ATS,ELEM,APET
402 DATA ER/452,451,451,0,450,0,453,454/
406 C JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
409 C JESLI TYPU FORMALNEGO - WEZ TEN TYP
410 IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
413 IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
414 IF(ELEM.GT.3)GO TO 600
416 C WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
420 cvax changed because of real appettite = 1
422 if (dswap .eq. 2) dswap = 1
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
438 400 CALL QUADR3(60+APET,ATS,SARRAY(K))
441 C.....TABLICA STATYCZNA
445 C JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
446 600 IF(ELEM.NE.10)GO TO 3000
447 C FUNKCJA. /BEZPARAMETROWA/
455 C ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
460 C-----------------------------------------------------------------------------
461 cdsw procedura podzielona na svalue i svalue2 - entry usuniete
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.
474 C WEJSCIE SVALUE - DLA CZUBKA STOSU
475 C WEJSCIE SVALU2 - DLA ELEMENTU PONIZEJ CZUBKA
477 C ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
479 C ##### DETECTED ERROR(S) : 450, 451, 452 , 453 , 454 .
485 C NUMERY BLEDOW "NIELEGALNE WYSTAPIENIE ... "
487 INTEGER ATS,ELEM,APET
488 DATA ER/452,451,451,0,450,0,453,454/
491 C JESLI UNIWERSALNY,STALA,WARTOSC - KONIEC
494 C JESLI TYPU FORMALNEGO - WEZ TEN TYP
495 IF(STACK(K-5).NE.0)STACK(K-5)=STYPFT(K)
498 IF(ELEM.EQ.1 .AND. STACK(K-7).EQ.0)GO TO 350
499 IF(ELEM.GT.3)GO TO 600
501 C WEZ NOWY ATS NA WARTOSC,WYZNACZ APETYT
505 cvax changed with real appetite = 1
507 if (dswap .eq. 2) dswap = 1
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
523 400 CALL QUADR3(60+APET,ATS,SARRAY(K))
526 C.....TABLICA STATYCZNA
530 C JESLI NA CZUBKU NIE FUNKCJA, TO BLAD
531 600 IF(ELEM.NE.10)GO TO 3000
532 C FUNKCJA. /BEZPARAMETROWA/
540 C ZASTAP ELEMENT PRZEZ "UNIWERSALNY",ZACHOWAJ NAZWE.
544 SUBROUTINE SVINT(ELEM)
545 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.
554 C ##### OUTPUT CODE : 58 .
556 C ##### DETECTED ERROR(S) : 408 .
566 equivalence (y, m(1))
569 DATA MAXINTEGER,MININTEGER / x'7FFFFFFF', x'80000000' /
571 DATA MAXINTEGER,MININTEGER / x'7FFF', -x'7FFF' /
578 IF(STACK(ELEM).NE.1)GO TO 100
581 C SPRAWDZ WARTOSC STALEJ
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)
596 C WARTOSC LUB ZMIENNA; GENERUJ KONWERSJE
598 CALL QUADR3(58,N,STACK(ELEM-2))
602 C STALA REAL O WARTOSCI POZA ZAKRESEM LICZB CALKOWITYCH
603 200 CALL SERRO2(408,ELEM)
604 C ZASTAP PRZEZ NAJWIEKSZA LICZBE CALKOWITA
606 IF(X.LT.0.0)N=MININTEGER
610 SUBROUTINE SVREAL(ELEM)
611 C-----------------------------------------------------------------------------
613 C POMOCNICZA. ZASTEPUJE ELEMENT /STALA,WARTOSC,ZMIENNA/ Z MIEJSCA
614 C ELEM STOSU TYPU INTEGER PRZEZ STALA LUB WARTOSC TYPU REAL.
616 C ##### OUTPUT CODE : 59 .
625 IF(STACK(ELEM).NE.1)GO TO 100
627 STACK(ELEM-2)=CREAL(FLOAT(STACK(ELEM-2)))
629 C WARTOSC,ZMIENNA; GENERUJ KONWERSJE
635 CALL QUADR3(59,N,STACK(ELEM-2))
640 SUBROUTINE SPUSH(ELEM)
641 C------------------------------------------------------------------------
643 C WSTAWIA NA STOS ELEMENT TYPU ELEM. USTAWIA VALTOP,VLPREV.
645 C PRZY PRZEPELNIENIU STOSU PRZERYWA KOMPILACJE !!!
647 C ( NA SKUTEK BRAKU NIELOKALNYCH SKOKOW NIE JEST MOZLIWY )
648 C ( SKOK DO ETYKIETY 2000 W SPASS2 I KOMPILACJA KOLEJNYCH )
652 C ##### DETECTED ERROR(S) : 550. /PRZEPELNIENIE STOSU /
658 VALTOP=VALTOP+STCKAP(ELEM)
659 IF(VALTOP.GE.FSTOUT)GO TO 100
662 C.....PRZEPELNIENIE STOSU
664 C GO TO 2000 CHANGED TO COMMENT DUE TO A.I.L./P.G. 15.05.84
666 C FOR STACK BEING OVERLOADED STOP THE COMPILATION
670 C--------------------------------------------------------------------------
672 C ZDEJMUJE 1 ELEMENT Z CZUBKA STOSU. USTAWIA VALTOP, VLPREV.
685 IF(VALTOP.LT.LSTSAF)LSTSAF=VALTOP
687 VLPREV=STCKAP(VLPREV)
688 C =APETYT NOWEGO CZUBKA STOSU
692 INTEGER FUNCTION SCONST(N)
693 C-----------------------------------------------------------------------------
696 C ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA O WARTOSCI N.
698 C ##### OUTPUT CODE : 199 .
706 CALL QUADR3(199,SCONST,N)
707 IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
710 INTEGER FUNCTION CREAL(X)
711 C----------------------------------------------------------------
713 C ZWRACA ADRES STALEJ X TYPU REAL W TABLICY STALYCH
715 C ##### DETECTED ERROR(S) : 554 .
717 IMPLICIT INTEGER (A-Z)
724 cvax data realsize/1/
725 cvax the size of real numbers on vax is 4 bytes ( = the size of integer)
727 100 if (staler(i) .eq.x) goto 200
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
739 equivalence (y, m(1))
744 100 if (ipmem(i) .eq. m(1) .and. ipmem(i+1) .eq. m(2)) goto 200
746 if (i .lt. irecn) goto 100
747 if (irecn + 2 .gt. ipmem(lmem)) goto 300
751 200 creal = (i+1) / 2
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
766 cdsw&bc 100 IF(STALER(CREAL).EQ.X)GO TO 200
767 cdsw&bc CREAL=CREAL+1
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
774 300 CALL SERRO2(554,0)
777 INTEGER FUNCTION SCREAL(N)
778 C----------------------------------------------------------------------------
781 C ZWRACA NOWY ATS ATRYBUTU ZAWIERAJACEGO STALA REAL O NUMERZE N
783 C ##### OUTPUT CODE : 197 .
795 C = SIZE OF REAL VALUE (NUMBER OF WORDS)
796 C LPMEM=INDEKS OSTATNIEGO SLOWA PRZEZ STALYMI REAL
800 K=(LPMEM+REALSIZE-1)/REALSIZE+1
801 C K=INDEKS PIERWSZEJ STALEJ W STALER
803 C = OFFSET WZGLEDEM ETYKIETY "RECON" RUN-TIME-U.
804 CALL QUADR3(197,SCREAL,K)
805 IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
809 INTEGER FUNCTION SWHAT(IND)
810 C----------------------------------------------------------------------------
813 C IND WSKAZUJE ZEROWE SLOWO OPISU ATRYBUTU /IND=MIDENT(NAZWA)/.
814 C FUNKCJA ROZPOZNAJE RODZAJ ATRYBUTU I ZWRACA JAKO WYNIK :
818 C 5 - "TABLICA STATYCZNA"
819 C 7 - "TYP FORMALNY" / "NAZWA TYPU"/
827 C W PRZYPADKU NIEPOPRAWNEGO OPISU ZWRACA UNIWERSALNY.
829 IMPLICIT INTEGER (A-Z)
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"
846 C ... ODCZYTAJ POLE "T" , BITY 12..15
849 C ... NIE TYP. POLE "ZP" , BITY 8..11
850 L=IAND(ISHFT(N,-4),15)
852 C ... PROCEDURA,FUNKCJA, POLE "S" , BITY 5..7
853 L=IAND(ISHFT(N,-8),7)+17
859 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="(".
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 .
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 ")" .
885 C DLA FUNKCJI (NIE-STANDARDOWEJ) GASI FLREADY.
887 C ##### OUTPUT CODE : 1 , 3 , 4 , 5 , 43 .
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
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
909 CALL QUADR3(43,N,STACK(LASTPR-2))
912 C.....FUNKCJA,PROCEDURA STANDARDOWA ?
913 IF(IND.LT.LPMSYS)GO TO 1000
920 C =RODZAJ ELEMENTU, 1..7 ZAMIAST 8..14
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
935 C.....PROCEDURA,FUNKCJA. VIRTUAL LUB PARAMETR ?
936 240 IF(KIND.EQ.0)GO TO 260
938 C CZYLI NIEZNANE OFFSETY
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)
944 270 IF(KIND.NE.2 .AND. STACK(VALTOP-7).EQ.0)GO TO 350
947 C.....BLOK PREFIKSOWANY
949 360 PROT=SPRFLD(.FALSE.)
950 C = WYZNACZONY DYNAMICZNIE PROTOTYP /BYC MOZE WRAZ Z OTOCZENIEM/
952 C.....WSPOLNE OTWARCIE POLA DANYCH : OPENRC,RAISE,OPEN,SLOPEN
954 400 CALL QUADR4(OPKOD,ADR,PHADR,PROT)
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
963 C DLA FUNKCJI BEZPARAMETROWEJ TEZ KONCZ WYWOLANIE
964 550 IF(ELEM.EQ.12 .AND. IPMEM(IND+4).EQ.1)GO TO 510
966 C.....PROCEDURA,FUNKCJA STANDARDOWA
967 1000 STACK(VALTOP-2)=0
969 C WYZEROWANE LICZNIKI PAR. INPUT I OUTPUT
973 C-------------------------------------------------------------------------
977 C OBSLUGUJE ZAKONCZENIE WYWOLANIA REKORDU,KLASY,BLOKU PREF.,
978 C PROCEDURY,FUNKCJI,SYGNALU.
980 C WOLANA : PRZY BRAKU PARAMETROW AKTUALNYCH PRZEZ SCALLB LUB
981 C PO WYSTAPIENIU ")" PRZEZ SDPDA.
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.
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.
1008 C ##### OUTPUT CODE : 2 , 21 , 54 , 58 , 59 , 132 , 143 , 145 ,
1009 C 150 , 153 , 159 , 160 , 170 .
1011 C ##### DETECTED ERROR(S) : 450 , 453 .
1018 COMMON / MASKS / MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
1019 * MPROCES, MCOR, MERPF, MBLOCK, MHAND
1022 C ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **
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
1037 CCCCCCCCCCCCCCCCCCCCCCCCCC
1038 INTEGER OPKOD,N,ELEM,CONTRL,IND,ATS,M
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
1050 C.....FUNKCJA,PROCEDURA STANDARDOWA ?
1051 STANDARD=( STACK(VALTOP-4) .LT. LPMSYS )
1052 IF(STANDARD)GO TO 2000
1054 C JESLI REKORD - PRZESKOCZ
1055 IF(STACK(VALTOP).EQ.8)GO TO 50
1056 C.....ZABEZPIECZ STOS
1058 C.....PRZEKAZ STEROWANIE
1061 IF(STACK(VALTOP-3).GT.8191)OPKOD=159
1063 C PRZEKAZ STEROWANIE Z ADRESEM FIZYCZNYM I AH NOWEGO OBIEKTU
1064 CALL QUADR3(OPKOD,PHADR,STACK(VALTOP-2))
1067 C PO POWROCIE Z GENEROWANEGO OBIEKTU:
1073 C NOWE ATS-Y NA ADR.FIZ. I VIRTUALNY
1074 CALL QUADR3(2,ATS,PHADR)
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/
1083 C.....JESLI SA PARAMETRY OUTPUT-ODCZYTAJ WARTOSCI
1084 50 M=IAND(STACK(VALTOP-3),SCALEHEX)
1085 C M=LICZBA PARAMETROW OUTPUT
1087 C DLA PROCEDURY STANDARDOWEJ NAJPIERW ODCZYTAJ WARTOSCI WSZYSTKICH
1089 IF(.NOT.STANDARD)GO TO 100
1092 C ODCZYTAJ WARTOSC N-TEGO PAR.OUTPUT PROC.STANDARDOWEJ
1093 C I WPISZ ATS TEJ WARTOSCI DO SLOWA -8
1097 90 STACK(ELEM-8)=SGETPAR(IND,VALTOP)
1102 C OBSLUZ N-TY PARAMETR OUTPUT /OD PRAWEJ DO LEWEJ/
1105 CONTRL=IAND(ISHFT(STACK(ELEM),-4),7)+1
1106 STACK(ELEM)=IAND(STACK(ELEM),15)
1107 C ODCZYTANE I WYZEROWANE BITY 9-11
1110 IF(STANDARD)GO TO 102
1111 C ODCZYTAJ WARTOSC PARAMETRU OUTPUT
1112 ATS=SGETPAR(IND,VALTOP)
1114 102 ATS=STACK(ELEM-8)
1116 C KONWERSJA LUB DYNAMICZNA KONTROLA
1117 103 IF(CONTRL.GT.3 .AND.OPTTYP)GO TO 300
1120 IF(IDR.EQ.0)GO TO 105
1122 C IDR = TYP FORMALNY PAR.AKT. LUB ZERO
1124 105 GO TO (300,110,120,130,140,150,160),CONTRL
1126 C KONWERSJA DO INTEGER
1128 CALL QUADR3(58,OPKOD,ATS)
1134 120 opkod = tstemp(1)
1136 120 opkod = tstemp(2)
1138 CALL QUADR3(59,OPKOD,ATS)
1142 C KONTROLA DYN.,OBA TYPY STATYCZNE
1143 130 CALL QUADR3(150,ATS,STACK(ELEM-4))
1147 140 IF(KIND.NE.0)GO TO 165
1149 CALL QUADR4(21,OPKOD,IPMEM(IND-4),IPMEM(IND-3))
1151 C WSTAW TYP STATYCZNY PAR.AKTUALNEGO
1152 150 IDR=STYPST(ELEM)
1154 160 IF(KIND.EQ.0)GO TO 170
1155 C NIEZNANY. ODCZYTAJ TYP PAR.FORMALNEGO
1156 165 OPKOD=SFPRST(NRPAR)
1159 cdsw 170 OPKOD=SPARF2(IND)
1160 cdsw ----------------------------
1161 170 opkod = sparft(ind,2)
1162 cdsw -----------------------------
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
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
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)
1185 C JESLI NA WEJSCIU JEST POCZATEK INSTRUKCJI LUB ETYKIETA - ZDEJMIJ
1187 IF(WB.EQ.32 .OR. WB.EQ.35 .OR. WB.EQ.44)CALL SPOP
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
1194 C ETYKIETA I USUNIECIE POLA DANYCH HANDLERA
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
1206 C PROCEDURA STANDARDOWA ?
1207 IF(STACK(VALTOP-4).LT.LPMSYS)GO TO 3000
1209 C.....BLOK PREFIKSOWANY. OBNIZ STOS,USUN POLE DANYCH
1211 810 CALL QUADR2(IDL,STACK(VALTOP-2))
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.
1221 RESULT=SGETPAR(IND,VALTOP)
1222 C = ATS ODCZYTANEJ WARTOSCI FUNKCJI
1223 C FUNKCJA STANDARDOWA ?
1224 IF(N.LT.LPMSYS)GO TO 4000
1226 C WSTAW TYP WARTOSCI
1227 STACK(VALTOP-3)=IPMEM(N-4)
1228 STACK(VALTOP-4)=IPMEM(N-3)
1229 C CZY TYPU FORMALNEGO?
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
1236 CALL QUADR4(54,N,STACK(VALTOP-2),STACK(VALTOP-4))
1238 C FUNKCJA FORMALNA LUB WIRTUALNA TYPU FORMALNEGO. ODCZYTAJ TEN TYP>
1240 940 STACK(VALTOP-5)=N
1242 C ZASTAP PRZEZ WARTOSC
1245 CALL QUADR2(143,STACK(VALTOP-2))
1246 STACK(VALTOP-2)=RESULT
1248 C...............WSPOLNE ZAKONCZENIE..............
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
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))
1273 C ... PRZEKAZ STEROWANIE
1274 2400 CALL QUADR2(132,OPKOD)
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
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
1295 4150 CALL SRESLT1(IPMEM(N-3))
1296 STACK(VALTOP-3)=IPMEM(N-4)
1302 C----------------------------------------------------------------------------
1304 C OBSLUGUJE WYWOLANIE FUNKCJI STANDARDOWYCH WYMAGAJACYCH
1305 C SPECJALNEJ OBSLUGI :
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.
1320 C ##### OUTPUT CODE : 42 , 53 , 60 , 100 , 101 , 116 , 131 .
1328 C = LICZBA ARGUMENTOW
1330 C = OPKOD DO WYPISANIA
1332 DATA ARGS/1,2,2,2,1,1,2/
1333 DATA OP/42,100,101,116,60,60,131,53/
1337 C = ADRES OPISU FUNKCJI
1339 C = LICZBA PAR. INPUT NA STOSIE , <= ARGS( .. )
1341 C = NUMER FUNKCJI, 1..7
1342 IF(ARGS(NR).EQ.2)GO TO 2000
1344 C.....JEDNOARGUMENTOWE. JEST ARGUMENT ?
1345 IF(N.EQ.0)GO TO 1500
1348 IF(STACK(VALTOP).EQ.1)GO TO 1700
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)
1361 C ... STALY ARGUMENT
1362 1700 IF(NR.NE.1)GO TO 1520
1363 RESULT=NOT(STACK(VALTOP-2))
1367 C.....DWUARGUMENTOWE. CZY SA OBA ARGUMENTY ?
1368 2000 TRESLT=IPMEM(IND-3)
1369 IF(N.EQ.2)GO TO 2200
1378 C = ATS-Y PIERWSZEGO I DRUGIEGO ARGUMENTU
1379 GO TO (2300,2400,2500,2450),ARG
1381 2300 GO TO (2320,2320,2330,2340,2301,2301,2370),NR
1384 2320 RESULT=IOR(IDL,IDR)
1387 2330 RESULT=IAND(IDL,IDR)
1390 2340 RESULT=ISHFT(IDL,IDR)
1392 2350 CALL SRESULT(1)
1395 2370 RESULT=IEOR(IDL,IDR)
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)
1405 C ... PRAWY STALY,LEWY NIE
1406 2500 IF(NR.EQ.4)GO TO 2600
1410 C ... ISHFT( .. , CONST )
1412 cbc IDR=IAND(IDR,31)
1413 IF(IDR.NE.0)GO TO 2450
1417 INTEGER FUNCTION STYPST(ELEM)
1418 C-----------------------------------------------------------------
1420 C ZWRACA /NOWY/ ATS TYPU STATYCZNEGO ELEMENTU Z MIEJSCA ELEM STOSU
1423 C ##### OUTPUT CODE : 21 .
1432 CALL QUADR4(21,STYPST,N,K)
1435 SUBROUTINE SPHADR(ELEM)
1436 C----------------------------------------------------------------------
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
1443 C ##### OUTPUT CODE : 47 .
1449 IF(PHADR.NE.0)RETURN
1450 C ZATEM TRZEBA ODTWORZYC ADRES FIZYCZNY
1452 CALL QUADR3(47,PHADR,STACK(ELEM-2))
1453 C ODCZYTAJ ADR.FIZYCZNY Z VIRTUALNEGO BEZ MEMBER
1457 integer function sparft(ind, numdsw)
1458 C-----------------------------------------------------------------------------
1459 cdsw dodatkowy parametr numdsw = 1 - wejscie sparft, = 2 - wejscie sparf2
1464 C DLA WOLANEGO MODULU /ZNANE OFFSETY/ ZWRACA ATS ZMODYFIKOWANEGO
1465 C TYPU FORMALNEGO PARAMETRU.
1467 C WEJSCIE SPARF2 : WOLANY MODUL JEST NA CZUBKU STOSU /Z SCALLE/
1468 C WEJSCIE SPARFT : WOLANY MODUL JEST PONIZEJ CZUBKA /Z SPARAM/
1470 C IND - ADRES OPISU PAR. FORMALNEGO W IPMEM
1472 C ##### OUTPUT CODE : 54 , 85 .
1481 cdsw ------------------------
1482 if(numdsw.eq.1) go to 1
1483 cdsw ------------------------
1485 C-----------------------
1486 cdsw ENTRY SPARF2(IND)
1489 C CZY TEN TYP FORMALNY JEST ATRYBUTEM LOKALNYM?
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)
1496 100 CALL QUADR4(85,SPARFT,PHADR,IND)
1497 C.....ZMODYFIKUJ TYP
1498 200 CALL SMODIFY(SPARFT,IPMEM(IND-4))
1502 INTEGER FUNCTION SGETPAR(IND,ELEM)
1503 C-------------------------------------------------------------------------
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.
1513 C ##### OUTPUT CODE : 23 , 52 , 61 , 62 , 63 , 84 , 85 , 86 .
1520 APET=SAPET(IPMEM(IND-4),IPMEM(IND-3))
1523 cvax changed because of real appetite = 1
1525 if (dswap .eq. 2) dswap = 1
1526 sgetpar = tstemp(dswap)
1528 SGETPAR=TSTEMP(APET)
1533 IF(STACK(ELEM-4).LT.LPMSYS)GO TO 300
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)
1540 C NIEZNANY OFFSET. WEZ ADRES FIZYCZNY PARAMETRU.
1542 CALL QUADR4(52,K,PHADR,NRPAR)
1543 C ODCZYTAJ APET-SLOW
1544 CALL QUADR3(60+APET,SGETPAR,K)
1546 C.....PROCEDURA,FUNKCJA STANDARDOWA
1547 300 APET=STACK(ELEM-4)
1548 CALL QUADR4(23,SGETPAR,IPMEM(APET+2),NRPAR)
1551 INTEGER FUNCTION STYPFT(ELEM)
1552 C-----------------------------------------------------------------------------
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/
1559 C ##### OUTPUT CODE : 15 , 22 , 54 , 85 .
1568 GO TO (200,300,200,300,199,199,199,199,199,199,300),N
1571 C.....WARTOSC LUB ELEMENT TABLICY. TYP JUZ JEST WYLICZONY
1572 200 STYPFT=STACK(ELEM-5)
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
1582 C ="ODCZYTAJ 2 SLOWA"
1584 C ODSZUKAJ TYP IDAC PO SL-ACH
1587 C ="ODCZYTAJ TYP FORMALNY IDAC PO SL-ACH"
1588 330 STYPFT=TSTEMP(2)
1589 CALL QUADR4(OPKOD,STYPFT,N,STACK(ELEM-4))
1591 C.....JESLI WB <> "(" ZMODYFIKUJ TYP
1592 335 IF(WB.NE.36)CALL SMODIFY(STYPFT,STACK(ELEM-3))
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
1600 CALL QUADR3(15,N,-STACK(ELEM-5))
1601 C N = ADR.VIRTUALNY POBRANY Z DISPLAYA
1603 C TYP FORMALNY MOZNA ODCZYTAC POPRZEZ DISPLAY Z WARSTWY= STACK(ELEM-5)
1604 350 STYPFT=STACK(ELEM-4)
1607 C CZY TYP JEST ATRYBUTEM LOKALNYM?
1608 IF(.NOT.MLOCTP(STYPFT,P))GO TO 330
1610 STYPFT=TSINSE(STYPFT,2)
1613 SUBROUTINE SMODIFY(N,L)
1614 C---------------------------------------------------------------
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.
1621 C ##### OUTPUT CODE : 87 .
1625 C A WIEC TRZEBA MODYFIKOWAC
1627 CALL QUADR4(87,K,N,L)
1631 SUBROUTINE SSTORE(ELEM,ATS)
1632 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
1640 C ##### OUTPUT CODE : 60 , 161 , 162 , 163 , 164 , 165 , 166 .
1645 INTEGER APET,ADRES,N
1652 GO TO (300,400,500),N
1654 C ZMIENNA. CZY PRZEZ KROPKE?
1655 300 IF(STACK(ELEM-7).EQ.0)GO TO 350
1657 CALL QUADR4(163+APET,SMEMBER(ELEM),ATS,ADRES)
1660 C ZMIENNA PRZEZ DISPLAY.
1661 350 CALL QUADR3(60,ADRES,ATS)
1666 C WPISZ APET-SLOW POD ADRES FIZYCZNY ELEMENTU TABLICY
1667 400 CALL QUADR3(160+APET,SARRAY(ELEM),ATS)
1674 INTEGER FUNCTION SARRAY(ELEM)
1675 C-----------------------------------------------------------------------------
1678 C ZWRACA ATS ADRESU FIZYCZNEGO ELEMENTU TABLICY Z MIEJSCA ELEM STOSU
1679 C USUWA EWENTUALNY MINUS W SLOWIE -2
1681 C ##### OUTPUT CODE : 64 , 65 , 102 , 103 , 104 , 105 .
1693 C CZY INDEKS JEST STALA?
1694 IF(STACK(ELEM-2).LT.0)GO TO 100
1697 C POMNOZ INDEKS PRZEZ 2 LUB 3
1699 CALL QUADR3(62+K,N,STACK(ELEM-7))
1700 50 CALL QUADR4(102+OPTIND+OPTMEM,SARRAY,STACK(ELEM-2),N)
1702 C.....INDEKS JEST STALA
1704 STACK(ELEM-2)= - STACK(ELEM-2)
1707 INTEGER FUNCTION SAPET2(ELEM)
1708 C-----------------------------------------------------------------------------
1710 C POMOCNICZA. ZWRACA APETYT /1,3,4/ DLA STALEJ,ZMIENNEJ,WARTOSCI
1711 C Z MIEJSCA ELEM STOSU.
1721 INTEGER FUNCTION SAPET(K,N)
1722 C-----------------------------------------------------------------------------
1724 C POMOCNICZA. ZWRACA APETYT/1,2,4/ DLA WARTOSCI TYPU (K,N)
1725 C 1 - INTEGER,BOOLEAN,STRING,CHAR
1727 C 4 - DOWOLNY TYP REFERENCYJNY
1730 IMPLICIT INTEGER (A-Z)
1738 IF(N.EQ.NRINT)RETURN
1739 IF(N.EQ.NRBOOL)RETURN
1740 IF(N.EQ.NRCHR)RETURN
1741 IF(N.EQ.NRTEXT)RETURN
1749 INTEGER FUNCTION SMEMBER(ELEM)
1750 C---------------------------------------------------------------------------
1752 C POMOCNICZA: ZWRACA /NOWY/ ATS ADRESU FIZYCZNEGO Z ADR.VIRT. ELEMENTU
1753 C Z MIEJSCA ELEM STOSU.
1755 C ##### OUTPUT CODE : 46 , 47 .
1764 CALL QUADR3(46+OPTMEM,SMEMBER,N)
1767 INTEGER FUNCTION SPRFLD(PARAM)
1768 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.
1781 C NIE UZYWANA DLA PROCEDUR,FUNKCJI STANDARDOWYCH.
1783 C ##### OUTPUT CODE : 15 , 16, 20 , 44 , 45 , 86 , 112 .
1792 INTEGER OPKOD,IND,ATS,N
1797 C IND=ADRES PROTOTYPU
1798 C.....CZY TO PARAMETR,VIRTUAL CZY "ZWYKLY" PROTOTYP?
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
1806 IF(STACK(VALTOP-7).EQ.0)GO TO 150
1808 125 ATS=STACK(VALTOP-7)
1809 C.....SKLEJ ADRES VIRTUALNY /ATS/ I NUMER PROTOTYPU /SPRFLD/ W 1 ARGUMENT.
1811 C OPKOD="SKLEJ W 1 ARG."
1813 135 SPRFLD=TSTEMP(3)
1814 CALL QUADR4(OPKOD,SPRFLD,ATS,N)
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.
1820 CALL QUADR3(15,ATS,IPMEM(IND-1))
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))
1832 C WYZNACZ PRZEZ DISPLAY PROTOTYP VIRTUALA
1833 250 CALL QUADR4(20,SPRFLD,IPMEM(IND-1),IPMEM(IND+27))
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.
1841 C OPKOD="WCZYTAJ 3 SLOWA Z POLA O ADR.FIZYCZNYM..."
1842 C ATS=ADR.FIZYCZNY,SPRFLD=ATS PARAMETRU
1844 C PARAMETR PRZEZ DISPLAY
1845 350 SPRFLD=TSINSE(IND,LOCAL)
1848 INTEGER FUNCTION SFPRST(N)
1849 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.
1855 C ##### OUTPUT CODE : 40 .
1862 CALL QUADR4(40,SFPRST,PHADR,N)
1865 INTEGER FUNCTION SPARST(N)
1866 C-----------------------------------------------------------------------
1868 C POMOCNICZA.WSTAWIA TYP STATYCZNY PARAMETRU FORMALNEGO.
1869 C N=ADRES OPISU PARAMETRU W IPMEM
1871 C ##### OUTPUT CODE : 21 .
1873 IMPLICIT INTEGER (A-Z)
1878 CALL QUADR4(21,SPARST,IPMEM(N-4),IPMEM(N-3))
1882 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.
1890 C ##### OUTPUT CODE : 195 .
1899 C ABY ZACHOWAC EWENTUALNY MINUS
1900 IF(N.GT.0) GO TO 100
1903 100 CALL QUADR3(195,LSTEMP,N)
1907 INTEGER FUNCTION TSTEMP(N)
1908 C------------------------------------------------------------------------
1911 C ##### OUTPUT CODE : 201 , 202 , 203 , 204 .
1919 CALL QUADR2(200+N,TSTEMP)
1920 IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
1923 INTEGER FUNCTION TSINSE(K,N)
1924 C-------------------------------------------------------------------------
1926 C K = ADRES OPISU ATRYBUTU W IPMEM
1927 C N = WIDZIALNOSC : 0 - GLOBALNY,1 - PRZEZ DISPLAY,2 - LOKALNY ATRYBUT
1929 C WYZNACZA ADRES OPISU ATRYBUTU W TABLICY SYMBOLI.
1930 C UZYWA POMOCNICZEGO SLOWNIKA ZAWIERAJACEGO TYLKO ATRYBUTY UZYTE
1931 C W BIEZACYM MODULE.
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
1940 C SLOWO +2 = ADRES W TABLICY SYMBOLI
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
1949 C ##### OUTPUT CODE : 205 , 206 , 207 .
1951 C ##### DETECTED ERROR(S) : 553 , 554 . ( PRZEPELNIENIA )
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
1965 TSINSE=IPMEM(TSINSE+2)
1967 C.....JESZCZE NIE. WYZNACZ NOWY ADRES W TABLICY SYMBOLI
1969 IF(IRECN.GT.J)GO TO 200
1974 IPMEM(TSINSE+2)=FRSTTS
1978 CALL QUADR3(205+N,TSINSE,K)
1979 IF(FRSTTS.GE.LSTEMP)CALL SSTOVF
1981 C.....PRZEPELNIENIE TABLICY SYMBOLI LUB SLOWNIKA STALYCH REAL
1982 200 CALL SERRO2(504,0)
1985 SUBROUTINE SCANCEL(ADR)
1986 C-----------------------------------------------------------------------------
1988 C JESLI ATRYBUT WSKAZANY PRZEZ ADR BYL UZYTY /JEST W TABLICY
1989 C SYMBOLI/ - PROCEDURA WYPISUJE OPKOD "CANCEL" , INACZEJ
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.
1997 C ##### OUTPUT CODE : 158 .
2000 IMPLICIT INTEGER (A-Z)
2005 C.....JEST W TABLICY SYMBOLI?
2007 IF(IPMEM(N).NE.P)RETURN
2008 IF(IPMEM(N+1).NE.ADR)RETURN
2010 CALL QUADR2(158,IPMEM(N+2))
2014 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.
2021 C DLA ELEMENTOW POWYZEJ LSTLSE ZABEZPIECZA WARTOSC ZMIENNYCH.
2023 C ##### OUTPUT CODE : 61 , 62 , 63 , 84 , 85 , 86 .
2030 C......ZACZNIJ OD POPRZEDNIEGO
2032 C CZY JEST COS NIEZABEZPIECZONEGO NAD OPISAMI PETLI FOR?
2033 100 IF(K.GT.LSTFOR .AND. K.GT.LSTSAF)GO TO 120
2039 C ELEM=RODZAJ ELEMENTU
2040 IF(ELEM.LT.2 .OR. ELEM.GT.5)GO TO 1000
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
2052 C N=RODZAJ APETYTU ZMIENNEJ
2054 cvax changed because of real appetite = 1
2056 if (dswap .eq.2) dswap = 1
2063 CALL QUADR4(83+N,L,SMEMBER(K),STACK(K-2))
2067 150 CALL SAFE(STACK(K-2))
2069 C ... ELEM.TABLICY. ODCZYTAJ WARTOSC
2072 cvax changed because of real appetite = 1
2074 if (dswap .eq.2) dswap = 1
2081 CALL QUADR3(60+N,L,SARRAY(K))
2083 C.....LSE : ZMIENNA,ELEM.TABLICY,TABLICA STATYCZNA.
2086 C.....WEZ POPRZEDNI ELEMENT
2087 1000 K=K-STCKAP(ELEM)
2094 SUBROUTINE QUADR4(N1,N2,N3,N4)
2095 C------------------------------------------------------------
2097 C WYPISUJE GENEROWANY KOD POSREDNI
2103 COMMON/TEST/TESTC,TESTS,TESTH
2104 LOGICAL TESTC,TESTS,TESTH
2105 common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2107 C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
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)
2124 IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2127 SUBROUTINE QUADR3(N1,N2,N3)
2128 C------------------------------------------------------------
2130 C WYPISUJE GENEROWANY KOD POSREDNI
2136 COMMON/TEST/TESTC,TESTS,TESTH
2137 LOGICAL TESTC,TESTS,TESTH
2138 common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2141 C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
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)
2155 IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2158 SUBROUTINE QUADR2(N1,N2)
2159 C------------------------------------------------------------
2161 C WYPISUJE GENEROWANY KOD POSREDNI
2167 COMMON/TEST/TESTC,TESTS,TESTH
2168 LOGICAL TESTC,TESTS,TESTH
2169 common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2171 C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2175 IF(.NOT.TESTC) GOTO 1000
2176 call ffputcs(13,' *******************')
2177 call ffputi (13,N1,8)
2178 call ffputi (13,N2,8)
2183 IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2186 SUBROUTINE QUADR1(N1)
2187 C------------------------------------------------------------
2189 C WYPISUJE GENEROWANY KOD POSREDNI
2195 COMMON/TEST/TESTC,TESTS,TESTH
2196 LOGICAL TESTC,TESTS,TESTH
2197 common/stream/errflg,line,ibuf2(265),ibuf3(7),junk(260)
2199 C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2203 IF(.NOT.TESTC) GOTO 1000
2204 call ffputcs(13,' *******************')
2205 call ffputi (13,N1,8)
2209 IF(LSTWRD.GE.LMEM-4)CALL QDROUT
2213 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.
2223 C BUFOR ZAJMUJE SLOWA LMEM-259 .. LMEM-1
2224 COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
2229 C WEZ NOWY NUMER REKORDU
2230 call ffwrite_ints(18, ipmem(lmem-259), 256)
2233 cdsw *********************************
2234 C PRZEPISZ OSTATNIE 3 SLOWA NA POCZATEK
2238 IPMEM(N+1)=IPMEM(M+1)
2239 IPMEM(N+2)=IPMEM(M+2)
2240 100 LSTWRD=LSTWRD-256
2243 SUBROUTINE SERROR(NUMER)
2244 C------------------------------------------------------------------------
2245 cdsw procedura podzielona na serror i serro2
2247 C SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
2248 C DLA 'UNIWERSALNEGO' NIE ROBI NIC.
2258 COMMON/TEST/TESTC,TESTS,TESTH
2259 LOGICAL TESTC,TESTS,TESTH
2263 100 IF(STACK(ELEM).EQ.0)RETURN
2266 IF(.NOT.TESTC) GOTO 1000
2267 call ffputcs(13,' ERROR')
2268 call ffputi (13,NUMER,6)
2269 call ffputi (13,NAZWA,8)
2273 CALL MERR(NUMER,NAZWA)
2276 SUBROUTINE SERRO2(NUMER,elem)
2277 C------------------------------------------------------------------------
2278 cdsw procedura podzielona na serror i serro2
2280 C SYGNALIZUJE BLAD O PODANYM NUMERZE DLA NAZWY Z CZUBKA STOSU.
2281 C DLA 'UNIWERSALNEGO' NIE ROBI NIC.
2291 COMMON/TEST/TESTC,TESTS,TESTH
2292 LOGICAL TESTC,TESTS,TESTH
2295 100 IF(STACK(ELEM).EQ.0)RETURN
2298 IF(.NOT.TESTC) GOTO 1000
2299 call ffputcs(13,' ERROR')
2300 call ffputi (13,NUMER,6)
2301 call ffputi (13,NAZWA,8)
2305 CALL MERR(NUMER,NAZWA)
2309 C---------------------------------------------------------------------------
2311 C SYGNALIZUJE PRZEPELNIENIE TABLICY SYMBOLI - BLAD 553
2318 common /stacks/ btsins, btstem
2323 C....PRZEPELNIENIE TABLICY SYMBOLI
2325 C OPROZNIJ TABLICE SYMBOLI
2326 cdsw&bc FRSTTS=LPMEM+1
2331 cdsw ---------- added -----------
2333 cdsw ------------------------------
2334 IPMEM(LMEM)=BOTTOM-1
2340 C---------------------------------------------------------------------
2342 C READ TESTING OPTIONS
2346 COMMON/TEST/TESTC,TESTS,TESTH
2347 LOGICAL TESTC,TESTS,TESTH
2350 cdsw BYTE HN,HNS,HY,HYS,HC,HS,HH
2351 cdsw ---------------------------------
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'/
2365 100 call ffputcs(0,' TESTING ? Y/N:')
2366 call ffgets (0,CHARS,80)
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
2372 call ffputcs(0,' OPTIONS : C - code , S - stack , H - halt')
2375 call ffgets (0,CHARS,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.
2382 cdsw IF(TESTH) CALL STOPAT
2394 C---------------------------------------------------------------------
2396 C WYPISUJE NA PLIK 15 HEKSADECYMALNA REPREZENTACJE
2397 C TABLICY SYMBOLI I L-KODU.
2403 COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
2405 C IBUF3 - OPIS STRUMIENIA Z WCZYTYWANYM I PRODUKOWANYM KODEM POSREDNIM
2409 EQUIVALENCE ( BL(1),IOP(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))
2420 common /stacks/ btsins, btstem
2426 c adres stalej none jest przekazany na zmiennej LOCAL ( numer 300 )
2428 call ffwrite_ints(15, bl(1), 302)
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)
2435 call ffwrite_ints(15, ipmem(1), irecn)
2438 call ffseek(18,offset)
2440 call ffread(18,buf1(1),len)
2441 if (len .eq. 0) goto 3010
2443 call ffwrite(15,buf1(1),wlen)
2444 if (len .eq. 31744) goto 3000