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 SUBROUTINE MPARPF (PAPROT, PAID, PAOB, DCONTR)
18 C-------------BADA ZGODNOSC PARAMETRU AKTUALNEGO (FUNKCJI/PROCEDURY)
19 C I PARAMETRU FORMALNEGO.
20 C PAPROT - NUMER PROTOTYPU AKTUALNEGO
21 C PAID - JEGO IDENTYFIKATOR ZE SCANNERA
22 C PAOB - DOSTEPNOSC PRZEZ DISPLAY
23 C DCONTR - NADAWANA JEST WARTOSC .TRUE., GDY KONIECZNA JEST
26 C 626 - NIEZGODNOSC RODZAJOW PARAMETROW FORMALNEGO I AKTUAL-
27 C NEGO (FUNKCJA<->PROCEDURA)
29 C 627 - NIEZGODNE RODZAJE PARAMETROW
30 C 628 - TYPY PARAMETROW SA NIEZGODNEGO RODZAJU
31 C 629 - TYPY PARAMETROW MAJA ROZLACZNE SEKWENCJE PREFIKSOWE
32 C 630 - NIEZGODNE DLUGOSCI LIST
34 C 631 - NIEZGODNE TYPY FUNKCJI AKTUALNEJ I FORMALNEJ
35 C 632 - PARAMETR AKTUALNY NIE JEST FUNKCJA ANI PROCEDURA
36 C 635 - PARAMETR AKTUALNY JEST FUNKCJA LUB PROCEDURA
39 C OPIS W DOKUMENTACJI: ?3.7.4
40 C WERSJA Z DNIA: 19.01.82
42 C.............................................................................
44 IMPLICIT INTEGER (A-Z)
50 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
54 COMMON /MCALLS/ CLLREC, UNICLL
56 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
58 C......BLOK KOMUNIKACJI PROCEDUR MPARPF ORAZ MPIO2
60 COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS,
63 C !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14 !!
71 C SPRAWDZENIE, CZY BEDZIE KONTROLA STATYCZNA
73 IF ( IPMEM(CLLREC+7) .EQ. 0) RETURN
74 IF (APROT .EQ. NRUNIV) RETURN
76 C------ KONTROLA ZGODNOSCI RODZAJOW
77 C PF - OPIS PARAMETRU FORMALNEGO
81 ZW = IAND ( ISHFT(ZW, -8), 7) + 1
82 C ZW - POLE S SLOWA ZEROWEGO PROTOTYPU AKTUALNEGO
83 GOTO (100, 100, 200, 100, 300, 100, 100, 100), ZW
85 C------ TO NIE JEST ANI FUNKCJA, ANI PROCEDURA
86 100 CALL MERR(632, AID)
89 C...... PARAMETR AKTUALNY JEST FUNKCJA
91 C PALGTH - BEDZIE DLUGOSCIA LISTY PF DLA PROTOTYPU AKTUALNEGO
92 IF (IPMEM(CLLREC+7) .EQ. 4) GOTO 1000
95 C...... PARAMETR AKTUALNY JEST PROCEDURA
97 IF (IPMEM(CLLREC+7) .EQ. 5) GOTO 2000
99 C------ NIEZGODNOSC RODZAJOW
100 900 CALL MERR(626, AID)
104 C***** PARAMETRY SA FUNKCJAMI
106 C--- ZBADANIE, CZY PF NIE JEST FUNKCJA DRUGIEGO RZEDU JESLI TAK
107 C TO KONIECZNA JEST KONTROLA DYNAMICZNA
109 IF (IPMEM(CLLREC+2) .EQ. 2) RETURN
111 C--- ZBADANIE ZGODNOSCI TYPOW FUNKCJI FORMALNEJ I AKTUALNEJ
112 CALL MFUNEQ (APROT, AID, AOB, PF, DCONTR)
115 C***** PARAMETRY SA PROCEDURAMI
117 IF (IPMEM(CLLREC+2) .EQ. 2) RETURN
121 C*************************************************************************
122 C WSPOLNA DLA FUNKCJI I PROCEDUR KONTROLA ZGODNOSCI LIST
125 IF (APROT .GT. LPMSYS) GOTO 3010
126 C --UZYTY MODUL STANDARDOWY
128 C TWORZONY JEST MALY REKORD ZAMIANY TYPOW (W CZESCI PRZEZNACZONEJ
129 C NA PROTOTYPY UZYTKOWNIKA
133 IF (BTEST(IPMEM(APROT),11)) DCLASS = .TRUE.
134 IF (IAND(ISHFT(IPMEM(APROT),-4),15) .NE. 0) AFORM = .TRUE.
135 DCLASS = DCLASS .OR. AFORM
136 C...... INICJALIZACJA
138 C ELEMENT LISTY PF FUN/PROC FORMALNEJ
140 IF (IPMEM(CLLREC+7) .EQ. 4) PFLGTH = PFLGTH-1
141 PAEL = IPMEM(APROT+3)
142 C ELEMENT LISTY PF FUN/PROC AKTUALNEJ
143 PALGTH = PALGTH + IPMEM(APROT+4)
146 C------ SPRAWDZENIE CZY SA JESZCZE PARAMETRY W OBYDWU LISTACH
147 IF ( (PALGTH .EQ. 0) .OR. (PFLGTH .EQ. 0) ) GOTO 6000
148 C --- SKOK DO POROWNANIA DLUGOSCI LIST
149 C*********************************
150 C***** POBRANIE I PRZETWARZANIE KOLEJNYCH PARAMETROW
152 4000 PFPF = IPMEM(PFEL)
154 C -PFPF - PARAMETR FORMALNY FUN/PROC FORMALNEJ
155 C -PFPA - PARAMETR FORMALNY FUN/PROC AKTUALNEJ
157 KINDPF = IAND (ISHFT(KINDPF, -4), 15) + 1
159 KINDPA = IAND(ISHFT(KINDPA, -4), 15) + 1
160 GOTO (5000, 4100, 4200, 4200, 5000, 4300, 4300, 5000,
161 X 5000, 4300), KINDPF
163 C......PFPF JEST TYPEM FORMALNYM
164 C PFPA TEZ MUSI BYC TYPEM FORMALNYM (LUB PARAMETREM
166 C WSTAWIENIE PARY DO MALEGO REKORDU
167 4100 KINDPF = MGETM(2,0)
169 IPMEM(KINDPF+1) = PFPA
170 IF (KINDPA .EQ. 2) GOTO 5000
171 IPMEM(KINDPF+1) = NRUNIV
172 IF (KINDPA .EQ. 1) GOTO 5000
173 C SKOK DO SYGNALIZACJI BLEDU
176 C......PFPF JEST FUNKCJA LUB PROCEDURA
177 C KONTROLA POLEGA JEDYNIE NA POROWNANIU RODZAJOW, GDYZ FUNKCJE I
178 C PROCEDURY FORMALNE 2 RZEDU NIE NIOSA ZADNEJ INFORMACJI
179 4200 IF (KINDPA .EQ. KINDPF) GOTO 5000
182 C......PFPF JEST PARAMETREM INPUT/OUTPUT/INOUT
183 C WYWOLANIE PROCEDURY KONTROLUJACEJ ZGODNOSC TYPOW
184 4300 IF (KINDPA .LE. 5 ) GOTO 4900
186 IF (KINDPF .EQ. KINDPA) GOTO 5000
188 C......NIEZGODNE RODZAJE PFPF I PFPA
189 4900 CALL MERR(627, AID)
190 C*****PRZESUNIECIE LIST PARAMETROW
195 IF ( (PFLGTH .NE. 0) .AND. (PALGTH .NE. 0) ) GOTO 4000
196 C***************************************
199 C-------ZBADANIE ZGODNOSCI DLUGOSCI LIST PF
200 C ZNISZCZENIE MALEGO REKORDU
202 IF (PFLGTH .EQ. PALGTH) GOTO 6300
203 IF (PFLGTH .LT. PALGTH) GOTO 6100
204 C LISTA AKTUALNA JEST KROTSZA, POWINNA BYC USZKODZONA BY NIE BYLO
206 C ZW - POLE S PROTOTYPU APROT
207 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6)) RETURN
209 C TU: LISTA PF JEST KROTSZA, TA POWINNA BYC USZKODZONA BY NIE BYLO
212 ZW = IAND(ISHFT(ZW, -8), 7) + 1
213 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6)) RETURN
214 C --- SYGNALIZACJA ROZNYCH DLUGOSCI LIST
215 6200 CALL MERR (630, AID)
217 C ---LISTY ROWNYCH DLUGOSCI, SYGNALIZACJA BLEDOW GDY (TYLKO) JEDNA Z NICH
219 6300 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6) ) GOTO 6100
220 C ---LISTA PARAMETROW MODULU AKTUALNEGO NIE JEST USZKODZONA, FORMALNEGO
221 C ---TEZ NIE POWINNA BYC
223 ZW = IAND (ISHFT(ZW, -8), 7) + 1
224 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6) ) GOTO 6200
225 C ---WSZYSTKO JEST W PORZADKU
229 SUBROUTINE MFUNEQ (PA, AID, AOB, PF, DCONTR)
230 C--------------PROCEDURA POMOCNICZA BADAJACA ZGODNOSC TYPOW FUNKCJI
231 C AKTUALNEJ(PA) I FORMALNEJ (PF).
232 C POZOSTALE PARAMETRY JAK W MPARPF.
233 C W RAZIE POTRZEBY NADAJE WARTOSC ZMIENNEJ DCONTR.
234 C SYGNALIZOWANE BLEDY:
235 C 631 - NIEZGODNE TYPY FUNKCJI AKTUALNEJ I FORMALNEJ
236 C 633 - TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY NIZ TYP
238 C OPIS W DOKUMENTACJI: ?3.7.2
239 C WERSJA Z DNIA: 19.01.82
241 C.............................................................................
243 IMPLICIT INTEGER (A-Z)
250 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
254 COMMON /MCALLS/ CLLREC, UNICLL
256 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
258 C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
259 COMMON /MTPC/ PRFXR, PRFXL
261 C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
263 C.....POBRANIE TYPU FUNKCJI AKTUALNEJ
266 C.....POBRANIE TYPU FUNKCJI FORMALNEJ
269 C.....MODYFIKACJA TYPU FUNKCJI FORMALNEJ W OPARCIU O REKORD KONTROLI
270 OBJL = IPMEM(CLLREC+3)
271 CALL MREPTP (TLDIM, TLBAS, OBJL)
272 C.....POBRANIE SLOW ZEROWYCH TYPOW BAZOWYCH - POLA T
273 AZW = IAND (IPMEM(TRBAS), 15)
274 FZW = IAND (IPMEM(TLBAS), 15)
275 C*****************************
276 IF ( (TLDIM .GT. 0) .OR. (TRDIM .GT. 0) ) GOTO 2000
280 C.....ROZPOZNANIE PRZYPADKU TYPOW PIERWOTNYCH
281 IF (AZW .GE. 8) GOTO 100
282 IF (FZW .GE. 8) GOTO 200
284 C --SKOK, GDY ZADEN TYP NIE JEST PIERWOTNY
286 C.....TRBAS (FUNKCJA AKTUALNA) JEST PIERWOTNY
287 100 IF (TLBAS .EQ. NRUNIV) RETURN
288 IF (TLBAS .EQ. TRBAS) RETURN
290 C --SKOK GDY TYPY SA NIEZGODNE
291 C.....TLBAS (FUNKCJA FORMALNA) JEST PIERWOTNY
292 200 IF (TRBAS .EQ. NRUNIV) RETURN
295 C*****TYPY ZLOZONE NIETABLICOWE
296 1000 IF ( (TLBAS .EQ. NRUNIV) .OR. (TRBAS .EQ. NRUNIV) ) RETURN
297 C.....OBYDWA TYPY SA KLASOWE, SYSTEMOWE LUB FORMALNE
298 IF (FZW .EQ. 6) GOTO 1100
299 IF (AZW .EQ. 6) GOTO 9200
300 C --TEN SKOK GDY TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY -
302 C.....OBYDWA TYPY SA KLASOWE LUB SYSTEMOWE
303 C TYP FUNKCJI FORMALNEJ MUSI PREFIKSOWAC TYP FUNKCJI AKTUALNEJ
304 IF (MPRFSQ (TLBAS, TRBAS) .NE. 0) GOTO 9000
305 C --SKOK GDY TAK NIE JEST
306 C ...DODATKOWA KONTROLA DYNAMICZNA JEST POTRZEBNA, GDY WYWOLYWANY MODUL
308 IF (IPMEM(CLLREC+2) .NE. 2) DCONTR = .TRUE.
311 C.....TYP TLBAS FUNKCJI FORMALNEJ JEST FORMALNY
312 1100 IF (AZW .EQ. 6) GOTO 1200
313 C ...TU TYP TLBAS JEST FORMALNY, TRBAS NIE - ZAWSZE POTRZEBNA KONTROLA
317 C.....OBYDWA TYPY SA FORMALNE
318 C - GDY WYWOLYWANY PROTOTYP JEST WIRTUALNY POTRZBNA KONTROLA DYNAMICZNA
319 C - W PRZECIWNYM PRZYPADKU ORAZ GDY TYPY ZAWSZE POCHODZA Z TEGO SAMEGO
320 C NIE MA KONTROLI DYNAMICZNEJ
321 1200 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 1250
324 IF (MTPCON(Z) .EQ. 1) RETURN
325 C ...POTRZEBNA KONTROLA DYNAMICZNA
330 C********************
331 C TYPY ZLOZONE TABLICOWE (CO NAJMNIEJ JEDEN)
332 2000 IF (TLDIM-TRDIM) 2100, 2200, 2300
334 C.....TLDIM<TRDIM (ZAWSZE KONTROLA DYNAMICZNA)
335 C POPRAWNE WOWCZAS, GDY TLBAS JEST FORMALNY LUB UNIWERSALNY
336 C - GDY OBA SA TYM SAMYM TYPEM FORMALNYM, TO POPRAWNE GDY
337 C - POCHODZA Z ROZNYCH OBIEKTOW
338 C - PROTOTYP WYWOLYWANY JEST WIRTUALNY
339 2100 IF (TLBAS .EQ. NRUNIV) RETURN
340 IF (FZW .NE. 6) GOTO 9100
344 IF (MTPCON(Z) .NE. 1) RETURN
345 IF (IPMEM(CLLREC+2) .NE. 0) RETURN
350 C - OBA TYPY BAZOWE SA ROWNE
351 C - TYP TLBAS JEST FORMALNY
352 C - TLBAS LUB TRBAS JEST UNIWERSALNY
353 2200 IF ( (TLBAS .EQ. NRUNIV) .OR. (TRBAS .EQ. NRUNIV) ) RETURN
354 IF (FZW .EQ. 6) GOTO 2250
355 IF (AZW .EQ. 6) GOTO 9200
356 C --SKOK DO SYGNALIZACJI TYPU SLABIEJ OKRESLONEGO
357 IF (TLBAS .EQ. TRBAS) RETURN
362 IF (MTPCON(Z) .NE. 1) DCONTR = .TRUE.
363 IF (IPMEM (CLLREC+2) .EQ. 1) DCONTR = .TRUE.
367 C POPRAWNE JEDYNIE, GDY OBA TYPY SA FORMALNE LUB UNIWERSALNE
368 2300 IF (TRBAS .EQ. NRUNIV) RETURN
369 IF (AZW .NE. 6) GOTO 9100
370 IF (TLBAS .EQ. NRUNIV) RETURN
371 IF (FZW .NE. 6) GOTO 9200
372 C ...OBYDWA SA FORMALNE
376 IF (MTPCON(Z) .NE. 1) RETURN
377 IF (IPMEM(CLLREC+2) .NE. 0) RETURN
380 C***********************************
381 C SYGNALIZACJE BLEDOW
382 C BADANIE OKRESLONOSCI TYPOW
383 9000 IF ( (AZW .EQ. 6) .AND. (FZW .NE. 6)) GOTO 9200
384 IF ( (TLBAS .NE. NRCOR) .AND.
385 X ( (TRBAS .EQ. NRCOR) .OR. (TRBAS .EQ. NRPROC) ) )
389 9100 CALL MERR(631, AID)
391 C.....TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY
392 9200 CALL MERR(633, AID)
396 SUBROUTINE MPIO2 (DCONTR)
397 C--------------PROCEDURA POMOCNICZA KONTROLUJACA ZGODNOSC TYPOW
398 C PARAMETROW FORMALNYCH 'INPUT'/'OUTPUT' DRUGIEGO
399 C RZEDU - TO ZNACZY WYSTEPUJACYCH W LISTACH ODPO-
400 C WIADAJACEJ MODULOWI FORMALNEMU (PF) ORAZ ODPO-
401 C WIADAJACEJ MODULOWI AKTUALNEMU (APROT)
402 C PFPF, PFPA - OPISY UZGADNIANYCH PARAMETROW
403 C /EWENTUALNA NIEZGODNOSC RODZAJOW PARAMETROW SYGNA-
404 C LIZOWANA JEST PRZEZ PROCEDURE MPARPF
405 C SYGNALIZOWANE BLEDY:
406 C 628 - NIEUZGODNIONE NAGLOWKI - TYPY PARAMETROW SA
407 C NIEZGODNYCH RODZAJOW
408 C 629 - NIEUZGODNIONE NAGLOWKI - TYPY PARAMETROW MAJA
409 C ROZLACZNE SEKWENCJE PREFIKSOWE
410 C 634 - NIEUZGODNIONE NAGLOWKI - TYP PARAMETRU W LISCIE
411 C AKTUALNEJ JEST SLABIEJ OKRESLONY
413 C OPIS W DOKUMENTACJI: ?3.7.3.5
414 C WERSJA Z DNIA: 19.01.82
416 C.............................................................................
418 IMPLICIT INTEGER (A-Z)
425 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
429 COMMON /MCALLS/ CLLREC, UNICLL
431 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
433 C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
434 COMMON /MTPC/ PRFXR, PRFXL
436 C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
438 C......BLOK KOMUNIKACJI PROCEDUR MPARPF ORAZ MPIO2
439 LOGICAL DCLASS, AFORM
440 COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS,
443 C !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14 !!
445 C.....POBRANIE TYPOW PARAMETROW PFPF I PFPA
446 TRDIM = IPMEM(PFPA-4)
447 TRBAS = IPMEM(PFPA-3)
448 AZW = IAND (IPMEM(TRBAS), 15)
449 TLDIM = IPMEM(PFPF-4)
450 TLBAS = IPMEM(PFPF-3)
451 OBJL = IPMEM(CLLREC+3)
452 C.....ODDZIELENIE PRZYPADKU, GDY KTORYS Z TYPOW SAM JEST PARAMETREM PF
454 IF (IPMEM(TLBAS-1) .EQ. PF) GOTO 1000
455 C --SKOK GDY TYP W MODULE FORMALNYM JEST WLASNYM PARAMETREM TEGO MODULU
456 IF (AZW .NE. 6) GOTO 2000
457 C --SKOK GDY TYP W MODULE AKTUALNYM NIE JEST FORMALNY
458 IF (IPMEM(TRBAS-1) .EQ. APROT) GOTO 1000
460 IF (MPRFSQ(IPMEM(TRBAS-1), APROT) .EQ. 1) GOTO 1000
461 C --SKOK GDY TYP W MODULE AKTUALNYM JEST WLASNYM PARAMETREM MODULU
464 C*****************************
465 C W CO NAJMNIEJ JEDNYM MODULE TYP JEST WLASNY W DRUGIM TEZ POWINIEN
466 C BYC WLASNYM PARAMETREM I OBA POWINNY SOBIE ODPOWIADAC
467 1000 IF (TLBAS .NE. NRUNIV) GOTO 1100
468 IF (TLDIM .LE. TRDIM) RETURN
470 1100 IF (TRBAS .NE. NRUNIV) GOTO 1200
471 IF (TLDIM .GE. TRDIM) RETURN
473 C.....ZADEN TYP NIE JEST UNIWERSALNY, OBYDWA POWINNY BYC WLASNE I SOBIE
475 1200 IF (AZW .NE. 6) GOTO 9100
476 IF (IPMEM(TRBAS-1) .EQ. APROT) GOTO 1300
478 IF (MPRFSQ(IPMEM(TRBAS-1), APROT) .NE. 1) GOTO 9100
479 IF (IPMEM(TLBAS-1) .NE. PF) GOTO 9100
480 IF (TLDIM .NE. TRDIM) GOTO 9100
481 C.....OBYDWA TYPY SA WLASNE I MAJA ROWNE WYMIARY,
482 C SPRAWDZENIE ODPOWIEDNIOSCI
484 1300 IF (IPMEM(AZW) .EQ. TLBAS) GOTO 1400
487 1400 TLBAS = IPMEM(AZW+1)
488 IF (TLBAS .EQ. TRBAS) RETURN
491 C****************************************************
492 C*******TYPY NIE SA WLASNYMI PARAMETRAMI MODULOW
493 C.....EWENTUALNA MODYFIKACJA TLBAS W OPARCIU O DUZY REKORD KONTROLI
494 2000 CALL MREPTP (TLDIM, TLBAS, OBJL)
495 FZW = IAND(IPMEM(TLBAS), 15)
496 IF ( (TLDIM .NE. 0) .OR. (TRDIM .NE. 0) ) GOTO 3000
498 C*********************
500 IF ( (TRBAS .EQ. NRUNIV) .OR. (TLBAS .EQ. NRUNIV) ) RETURN
501 C.....ODDZIELENIE TYPOW PRYMITYWNYCH
502 IF (FZW .GE. 8) GOTO 2200
503 IF (AZW .GE. 8) GOTO 2200
504 C.....ZADEN TYP NIE JEST PRYMITYWNY
505 C.....ODDZILENIE TYPOW FORMALNYCH
506 IF (FZW .EQ. 6) GOTO 2300
507 IF (AZW .EQ. 6) GOTO 9300
508 C --TEN SKOK GDY TYP W MODULE FORMALNYM JEST STATYCZNIE OKRESLONY,
509 C NATOMIAST W MODULE AKTUALNYM JEST FORMALNY
510 C **OBYDWA TYPY SA STATYCZNIE OKRESLONE - KLASOWE LUB SYSTEMOWE
511 IF (TLBAS .EQ. TRBAS) GOTO 2100
512 IF (MPRFSQ (TLBAS, TRBAS) .EQ. -1) GOTO 9200
513 C --TYPY MAJA ROZLACZNE SEKWENCJE PREFIKSOWE - SKOK DO
515 IF (DCLASS) DCONTR = .TRUE.
516 IF (IPMEM(CLLREC+2) .NE. 0) DCONTR = .TRUE.
518 C DODATKOWA KONTROLA JEST POTRZEBNA GDY MODUL AKTUALNY NIE JEST
520 2100 IF ((IPMEM(CLLREC+2) .NE. 0) .AND. DCLASS) DCONTR = .TRUE.
521 C TYPY BYLY ROWNE - DODATKOWA KONTROLA DYNAMICZNA JEST
522 C POTRZEBNA GDY JEDNOCZESNIE MODUL WYWOLYWANY BYL WIRTUALNY
523 C ORAZ MODUL AKTUALNY NIE BYL RZECZYWISTY
526 C **CO NAJMNIEJ JEDEN TYP JEST PRYMITYWNY, DRUGI POWINIEN BYC MU ROWNY
527 2200 IF(TLBAS .EQ. TRBAS) RETURN
530 C **CO NAJMNIEJ TYP TLBAS JEST FORMALNY
531 C TRBAS MOZE BYC WOWCZAS KLASOWY, SYSTEMOWY LUB FORMALNY
532 2300 IF (AZW .EQ. 6) GOTO 2400
533 C ...TYLKO TLBAS JEST FORMALNY - POTRZEBNA KONTROLA DYNAMICZNA
536 C ...OBYDWA TYPY SA FORMALNE
537 C KONTROLA DYNAMICZNA JEST ZAWSZE KONIECZNA, GDY WYWOLYWANY MODUL JEST
539 2400 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 2350
540 C ...KONTROLI DYNAMICZNEJ NIE MA, GDY TYP JEST TEN SAM I ZAWSZE
541 C POCHODZI Z TEGO SAMEGO OBIEKTU
544 IF (MTPCON(Z) .EQ. 1) RETURN
549 C****************************************
551 3000 IF (TLDIM - TRDIM) 3100, 3200, 3300
554 C MOZE BYC POPRAWNE JEDYNIE GDY TLBAS JEST FORMALNY LUB UNIWERSALNY
555 C GDY TYPY SA TYM SAYM TYPEM FORMALNYM, TO POPRAWNE GDY POCHODZA Z
556 C ROZNYCH OBIEKTOW LUB APROT ALBO PROTOTYP WYWOLYWANY SA WIRTUALNE
557 3100 IF (TLBAS .EQ. NRUNIV) RETURN
558 IF (FZW .NE. 6) GOTO 9100
559 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 3150
560 IF (BTEST(IPMEM(APROT),11)) GOTO 3150
563 IF (MTPCON(Z) .EQ. 1) GOTO 9100
568 C POPRAWNE, GDY OBYDWA TYPY SA STATYCZNIE OKRESLONE I ROWNE LUB
569 C TLBAS JEST FORMALNY LUB
570 C TLBAS, TRBAS JEST UNIWERSALNY LUB
571 C OBYDWA SA FORMALNE - WTEDY GDY PROTOTYP WYWOLYWANY NIE JEST WIRTUALNY
572 C ANI MODUL AKTUALNY NIE JEST WIRTUALNY, TO KONTROLA DYNAMICZNA NIE JEST
573 C POTRZEBNA O ILE TYPY SA ROWNE I ZAWSZE POCHODZA Z TEGO SAMEGO OBIEKTU
574 3200 IF ( (TLBAS .EQ. NRUNIV) .OR. (TRBAS .EQ. NRUNIV) ) RETURN
575 IF (FZW .EQ. 6) GOTO 3210
576 IF (TLBAS .EQ. TRBAS) RETURN
577 IF (AZW .EQ. 6) GOTO 9300
579 C ...TYP TLBAS JEST FORMALNY
580 3210 IF (AZW .EQ. 6) GOTO 3230
583 C ...OBYDWA TYPY SA FORMALNE
584 3230 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 3220
585 IF (BTEST(IPMEM(APROT), 11)) GOTO 3220
588 IF (MTPCON (Z) .NE. 1) GOTO 3220
591 C.....TLDIM>TRDIMCPOPRAWNE JEDYNIE, GDY OBYDWA TYPY SA FORMALNE LUB
593 3300 IF (TRBAS .EQ. NRUNIV) RETURN
594 IF (AZW .NE. 6) GOTO 9100
595 IF (TLBAS .EQ. NRUNIV) RETURN
596 IF (FZW .NE. 6) GOTO 9300
597 C ...OBYDWA TYPY SA FORMALNE
601 IF (MTPCON(Z) .NE. 1) RETURN
602 IF (IPMEM(CLLREC+2) .NE. 0) RETURN
603 IF (BTEST(IPMEM(APROT), 11)) RETURN
606 C***************************************
607 C SYGNALIZACJE BLEDOW
608 9100 CALL MERR(628, AID)
610 C BADANIE OKRESLONOSCI TYPOW
611 9200 IF ( (TLBAS .NE. NRCOR) .AND.
612 X ( (TRBAS .EQ. NRCOR) .OR. (TRBAS .EQ. NRPROC))) GOTO 9300
615 9300 CALL MERR(634, AID)
619 INTEGER FUNCTION MPARIO (ATDIM, ATBASE, ID, AOB)
620 C-------------BADA ZGODNOSC TYPU PARAMETRU AKTUALNEGO (ATDIM, ATBASE)
621 C Z TYPEM PARAMETRU FORMALNEGO (INPUT/OUTPUT).
622 C ID - IDENTYFIKATOR UZYWANY W SYGNALIZACJI BLEDOW (NP. NAZWA
624 C AOB - OBIEKT W CIAGU SL, Z KTOREGO BRANY JEST PARAMETR
625 C AKTUALNY, LUB 0 - GDY NIE JEST DOSTEPNY PRZEZ
627 C / WARTOSC FUNKCJI INFORMUJE O KONWERSJI LUB KONTROLI
628 C DYNAMICZNEJ - TAK JAK W MSUBST.
629 C ODPOWIEDNIOSC JEST NASTEPUJACA:
631 C LEWA STRONA - PARAMETR FORMALNY
632 C PRAWA STRONA - PARAMETR AKTUALNY
634 C LEWA STRONA - PARAMETR AKTUALNY
635 C PRAWA STRONA - PARAMETR FORMALNY
636 C DODATKOWE UWAGI KONTEKSTOWE:
637 C - W PRZYPADKU FUNKCJI I PROCEDUR WIRTUALNYCH - TYPY FOR-
638 C MALNE SA ZAWSZE ZGODNE (ROZNICA W DZIALANIU MSUBST),
639 C WYMAGANA JEST JEDNAK ZAWSZE KONTROLA DYNAMICZNA
640 C - GDY FUN/PROC JEST WIRTULNA LUB FORMALNA - TYPY KLASOWE SA
641 C ZGODNE JESLI SA WE WSPOLNEJ SEKWENCJI PREFIKSOWEJ- KONTRO-
642 C LA DYNAMICZNA ROWNIEZ ZAWSZE POTRZEBNA
644 C SYGNALIZOWANE BLEDY
646 C 609 - NIEZGODNE TYPY
647 C 610 - ROZLACZNE SEKWENCJE PREFIKSOWE
649 C OPIS W DOKUMENTACJI: ?3.6.2
650 C WERSJA Z DNIA: 19.01.82
652 C.............................................................................
654 IMPLICIT INTEGER (A-Z)
656 C FNFORM MA WARTOSC .TRUE. GDY PARAMETR FORMALNY NIE JEST
662 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
666 COMMON /MCALLS/ CLLREC, UNICLL
668 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
673 C...... KONTROLA WYWOLANIA UNIWERSALNEGO
675 IF (IPMEM(CLLREC+7) .EQ. 0) RETURN
677 C------POBRANIE TYPU PARAMETRU FORMALNEGO
680 C ... PF OPIS PARAMETRU FORMALNEGO
683 C ...FDIM, FBAS - NIEZMODYFIKOWANY TYP PARAMETRU FORM.
685 FOB = IPMEM(CLLREC+3)
686 C PARAMETR FORMALNY "POCHODZI" Z TEGO SAMEGO OBIEKTU, CO OBIEKT
689 C------BADANIE RODZAJU OBIEKTU WYWOLYWANEGO
691 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 1000
693 C------ WYWOLYWANY ZWYKLY OBIEKT
694 C...... MODYFIKACJA TYPU PARAMETRU FORMALNEGO
695 IF ( IAND( IPMEM(FBAS), 15) .EQ. 6) FNFORM = .FALSE.
696 CALL MREPTP(FDIM, FBAS, FOB)
697 C......BADANIE RODZAJU PARAMETRU FORMALNEGO
698 IF (IPMEM(CLLREC+7) .EQ. 6) GOTO 95
699 IF (IPMEM(CLLREC+7) .EQ. 2) GOTO 100
700 C --- KONTROLA PARAMETRU INPUT
713 C....ZMIANA INFORMACJI O KONTROLI DYNAMICZNEJ GDY PARAMETR
714 C FORMALNY JEST TYPU FORMALNEGO
715 90 IF ( (MPARIO .EQ. 3) .OR. (MPARIO .EQ. 5) ) MPARIO =
718 C ---KONTROLA 'INOUT' - JAK OUTPUT PRZY PIERWSZYM WYWOLANIU, INPUT PRZY
720 95 IPMEM(CLLREC+7) = -6
721 C --- KONTROLA PARAMETRU OUTPUT
733 110 IF ( (MPARIO .EQ. 3) .OR. (MPARIO .EQ. 4) ) MPARIO =
737 C------ OBIEKTY FORMALNE I WIRTUALNE
738 C ---UWAGA: OBIEKTY WIRTUALNE NIGDY NIE SA DOSTEPNE PRZEZ DISPLAY
739 1000 IF (IPMEM(CLLREC+2) .EQ. 1) FOB = 0
740 C...... MODYFIKACJA TYPU PARAMETRU FORMALNEGO
741 IF ( IAND( IPMEM(FBAS), 15) .EQ. 6) FNFORM = .FALSE.
742 CALL MREPTP(FDIM, FBAS, FOB)
743 C...... BADANIE RODZAJU PARAMETRU FORMALNEGO
744 IF (IPMEM(CLLREC+7) .EQ. 2) GOTO 1100
745 C --- KONTROLA PARAMETRU INPUT
756 IF (FNFORM) GOTO 1200
758 C --- KONTROLA PARAMETRU OUTPUT
769 C...... SPRAWDZENIE, CZY NIE SA TO TYPY KLASOWE- DLA NICH ZAWSZE
770 C KONTROLA DYNAMICZNA
771 IF ( .NOT. FNFORM) GOTO 110
772 1200 IF(MPARIO .NE. 0) RETURN
773 C ... PF - OPIS PARAMETRU FORMALNEGO
774 IF (IPMEM(PF-4).NE.0) RETURN
776 C ..PF - OPIS TYPU PARAMETRU
777 PF = IAND (IPMEM(PF), 15)
778 IF (PF .GE. 8) RETURN
783 INTEGER FUNCTION MSUBST (X)
786 C-------------PROCEDURA BADA POPRAWNOSC INSTRUKCJI PODSTAWIENIA.
787 C JEST ROWNIEZ WYWOLYWANA W PROCEDURZE KONTROLI
788 C TYPOW PARAMETROW FORMALNYCH I AKTUALNYCH.
790 C - TLDIM, TLBAS - TYP LEWEJ STRONY INSTRUKCJI PODSTAWIENIA,
791 C OBJL - PROTOTYP, Z KTOREGO POCHODZI, LUB 0 - NIEDOSTEPNA
793 C IDL - IDENTYFIKATOR LEWEJ STRONY (DO SYGNALIZACJI
795 C - ANALOGICZNIE DLA PRAWEJ STRONY - TRDIM, TRBAS,
797 C // WARTOSC FUNKCJI OKRESLA RODZAJ KONWERSJI LUB KONTROLI
799 C 0 - OBIE STRONY SA TEGO SAMEGO TYPU,
800 C 1 - INTEGER := REAL
801 C 2 - REAL := INTEGER
802 C DYNAMICZNA KONTROLA TYPOW
803 C 3 - OBA TYPY OKRESLONE (STATYCZNIE)
804 C 4 - TYP LEWEJ STRONY FORMALNY, PRAWEJ OKRESLONY
805 C 5 - TYP LEWEJ STRONY OKRESLONY, PRAWEJ FORMALNY
806 C 6 - TYPY OBYDWU STRON FORMALNE
807 C ----SYGNALIZOWANE BLEDY
808 C 609 - NIEZGODNE TYPY W PODSTAWIENIU
809 C 610 - TYPY W PODSTAWIENIU MAJA ROZLACZNE SEKWENCJE PREFI-
811 C 636 - NIEDOZWOLONE UZYCIE SEMAFORA
813 C OPIS W DOKUMENTACJI: ?2.7
814 C WERSJA Z DNIA: 19.01.82
816 C.............................................................................
818 IMPLICIT INTEGER (A-Z)
824 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
826 C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
827 COMMON /MTPC/ PRFXR, PRFXL
829 C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
831 C INICJOWANA WARTOSC MSUBST - 3 ODPOWIADAJACA KONTROLI DYNAMICZNEJ
833 IF ( (TLDIM .EQ. 0) .AND. (TLBAS .EQ. NRUNIV) ) RETURN
834 IF ( (TRDIM .EQ. 0) .AND. (TRBAS .EQ. NRUNIV) ) RETURN
835 C POWROTY - GDY JEDEN Z TYPOW JEST UNIWERSALNY
837 TPL = IAND (IPMEM(TLBAS), 15)
838 TPR = IAND(IPMEM(TRBAS), 15)
839 C TPL I TPR - POLA T Z OPISU TYPOW TLBAS I TRBAS
840 IF ( (TLDIM .NE. 0) .OR. (TRDIM .NE. 0) ) GOTO 1000
841 C SKOK DO BADANIA PODSTAWIEN DLA TYPOW TABLICOWYCH
842 C------ TYPY NIETABLICOWE - ZADEN Z NICH NIE JEST JUZ UNIWERSALNY
844 GOTO (9000, 100, 100, 9500, 100, 200, 100, 300, 9100, 400, 500,
845 X 400, 9000, 9000), TPL
847 C...... TPL JEST TYPEM KLASOWYM LUB SYSTEMOWYM
848 100 GOTO (9000, 110, 110, 9500, 110, 150, 110, 9000, 9100, 9000,
849 X 9000, 9000, 9000, 130), TPR
850 C ... TPR JEST ROWNIEZ TYPEM KLASOWYM LUB SYSTEMOWYM
851 C SPRAWDZENIE PREFIKSOWANIA
852 110 IF ( MPRFSQ(TLBAS, TRBAS) ) 120, 130, 140
853 C SEKWENCJE PREFIKSOWE ROZLACZNE - PODSTAWIENIE MOZE BYC POPRAW-
854 C NE JEDYNIE GDY JEDEN Z TYPOW JEST SYSTEMOWY
855 120 IF ( (TRBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRCOR) ) RETURN
856 IF ( (TRBAS .EQ. NRPROC) .OR. (TLBAS .EQ. NRPROC) ) RETURN
860 C TPL JEST PREFIKSEM TPR - KONTROLA DYNAMICZNA NIE JEST
861 C POTRZEBNA, TPR MOZE BYC ROWNIEZ NONE
865 C TPR JEST PREFIKSEM TPL - KONTROLA DYNAMICZNA JEST POTRZEBNA
866 C KONTEKSTOWO SYTUACJA JEST POPRAWNA
868 C ... TPR JEST FORMALNY
873 C...... TPL JEST TYPEM FORMALNYM - TPR MUSI BYC TYPEM FORMALNYM, KLASO-
874 C WYM, SYSTEMOWYM LUB NONE
876 GOTO (9000, 210, 210, 9500, 210, 220, 210, 9000, 9100, 9000,
877 X 9000, 9000, 9000, 210) , TPR
878 C ...TPR - KLASOWY, SYSTEMOWY LUB NONE
884 IF ( MTPCON(Z) .EQ. 1) MSUBST = 0
888 C...... TPL JEST ARYTMETYCZNY, TPR TEZ MUSI BYC ARYTMETYCZNY
889 300 IF ( (TRBAS .NE. NRINT) .AND. (TRBAS .NE. NRRE) ) GOTO 9000
891 IF (TLBAS .EQ. TRBAS) RETURN
892 C TU - TYPY ROZNE - POTRZEBNA KONWERSJA
894 IF (TLBAS .EQ. NRINT) MSUBST = 1
897 C...... TPL - INNY PRYMITYWNY, TPR MUSI BYC MU ROWNE
899 IF (TLBAS .EQ. TRBAS) RETURN
901 C.......TPL - FILE, TPR MUSI BYC FILE LUB NONE
903 IF ((TLBAS .EQ. TRBAS) .OR. (TRBAS .EQ. NRNONE)) RETURN
907 C------ CO NAJMNIEJ JEDEN TYP JEST TABLICOWY
909 1000 IF (TLDIM - TRDIM) 2000, 3000, 4000
910 C...... PRZYPADEK TLDIM < TRDIM
911 C WOWCZAS PODSTAWIENIE JEST POPRAWNE JEDYNIE, GDY TLBAS JEST FOR-
912 C MALNY LUB UNIWERSALNY. W PRZYPADKU, GDY OBA TYPY SA TYM SAMYM
913 C TYPEM FORMALNYM - MUSZA POCHODZIC Z ROZNYCH OBIEKTOW.
914 2000 IF (TPL .EQ. 4) RETURN
915 C POWROT DLA TYPU UNIWERSALNEGO
916 IF (TPL .NE. 6) GOTO 9000
917 C SKOK DO SYGNALIZACJI BLEDU DLA TYPU NIEFORMALNEGO
919 IF (TPR .EQ. 6) MSUBST = 6
922 C......PRZYPADEK TLDIM = TRDIM
924 C - OBA TYPY BAZOWE SA ROWNE
925 C - CO NAJMNIEJ JEDEN JEST FORMALNY LUB UNIWERSALNY
926 3000 IF ( (TPL .EQ. 4) .OR. (TPR .EQ. 4) ) RETURN
927 C POWROT - GDY JEDEN Z TYPOW JEST UNIWERSALNY
929 IF ( (TPL .EQ. 6) .AND. (TPR .EQ. 6) ) GOTO 3300
930 IF (TPL .EQ. 6) GOTO 3100
931 IF (TPR .EQ. 6) GOTO 3200
932 C SKOKI ROZDZIELAJACE PRZYPADKI TYPOW FORMALNYCH
933 C ... PRZYPADEK, GDY TYPY NIE SA FORMALNE
935 IF (TLBAS .EQ. TRBAS) RETURN
936 C TU - NIEROWNE TYPY NIEFORMALNE - SKOK DO SYGNALIZACJI BLEDOW
939 C ... TLBAS JEST FORMALNY, TRBAS NIE
942 C ... TRBAS JEST FORMALNY, TLBAS NIE
945 C ... TLBAS I TRBAS SA FORMALNE, SPRAWDZENIE,CZY SA ROWNE I LOKALNE
946 C (WTEDY NIE MA KONTROLI DYNAMICZNEJ)
950 IF ( MTPCON(Z) .EQ. 1) MSUBST = 0
953 C...... PRZYPADEK TLDIM > TRDIM
955 C - TYP NONE Z PRAWEJ STRONY
956 C - TRBAS JEST FORMALNY LUB UNIWERSALNY, W PRZYPADKU GDY OBA
957 C TYPY SA TYM SAMYM TYPEM FORMALNYM CO NAJMNIEJ JEDEN Z NICH
958 C MUSI BYC NIELOKALNY
960 IF (TPR .EQ. 4) RETURN
961 C POWROT DLA TYPU UNIWERSALNEGO Z PRAWEJ STRONY
962 IF ( (TPR .EQ. 14) .AND. (TRDIM .EQ. 0) ) RETURN
963 C POWROT DLA STALEJ NONE
964 IF (TPR .NE. 6) GOTO 9000
965 C SKOK DO SYGNALIZACJI BLEDU DLA TYPU NIEFORMALNEGO
967 IF (TPL .EQ. 6) MSUBST = 6
968 C GOTO 8000 - PRZEJSCIE DO BADANIA TYPOW TABLICOWYCH
971 C------ BADANIE ZGODNOSCI FORMALNYCH TYPOW TABLICOWYCH
975 IF ( MTPCON(Z) .EQ. 1) GOTO 9000
980 C------SYGNALZACJA BLEDOW
981 9000 IF (TPR .EQ. 9) GOTO 9100
984 9100 IF (TPL .EQ. 9) CALL MERR(636, IDL)
985 IF (TPR .EQ. 9) CALL MERR(636, IDR)
989 SUBROUTINE MEQUAL (CASE)
990 C-------------PROCEDURA BADA ZGODNOSC ARGUMENTOW RELACJI = I =/= .
991 C TYPY PRAWEGO I LEWEGO ARGUMENTU PRZEKAZANE SA PRZEZ
992 C BLOK /SEMANT/ , SA TO :
993 C TLDIM, TLBAS - DLA LEWEGO ARGUMENTU
994 C TRDIM, TRBAS - DLA PRAWEGO ARGUMENTU.
995 C ZMIENNE OBJL, OBJR - NUMERY PROTOTYPOW OBIEKTOW, KTORYCH
996 C ATRYBUTAMI SA ODPOWIEDNIO LEWY I PRAWY ARGUMENT OPERACJI.
997 C SA ONE ROWNE ZERU, GDY ARGUMENTY NIE SA DOSTEPNE PRZEZ
999 C ZMIENNE IDL ORAZ IDR SLUZA DO IDENTYFIKACJI BLEDOW - SA
1000 C TO IDENTYFIKATORY LEWEGO I PRAWEGO ARGUMENTU.
1001 C // WARTOSCI PARAMETRU CASE PRZY WYJSCIU OKRESLAJA :
1002 C 1 - OBA ARGUMENTY SA INTEGER
1003 C 2 - CO NAJMNIEJ JEDEN ARGUMENT JEST TYPU REAL, DRUGI
1004 C MUSI BYC ARYTMETYCZNY. ZMIENNE CONVL I CONVR OKRE-
1005 C SLAJA EWENTUALNA KONWERSJE
1006 C 3 - OBA ARGUMENTY SA BOOLOWSKIE
1007 C 4 - OBA ARGUMENTY SA TYPU CHAR
1008 C 5 - OBA ARGUMENTY SA TYPU REFERENCYJNEGO (ROWNIEZ
1009 C TABLICOWEGO, TEGO SAMEGO FORMALNEGO I PLIKOWEGO)
1010 C - ZGODNE STATYCZNIE
1011 C 6 - J.W. - CO NAJMNIEJ JEDEN JEST FORMALNY I WYMAGANA
1012 C DYNAMICZNA KONTROLA ZGODNOSCI
1013 C ----SYGNALIZOWANE BLEDY:
1014 C 606 - RODZAJE TYPOW WYSTEPUJACYCH W POROWNANIU SA NIEZGO-
1016 C 607 - W POROWNANIU BIORA UDZIAL TYPY KLASOWE Z ROZLACZNA
1017 C SEKWENCJA PREFIKSOWA
1018 C 608 - POROWNYWANY JEST TYP STRING
1019 C 636 - NIEDOZWOLONE UZYCIE SEMAFORA
1021 C OPIS W DOKUMENTACJI: ?2.6
1022 C WERSJA Z DNIA: 13.05.83 (FRIDAY)
1024 C.............................................................................
1026 IMPLICIT INTEGER (A-Z)
1032 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1034 C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
1035 COMMON /MTPC/ PRFXR, PRFXL
1037 C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
1041 TPL = IAND( IPMEM(TLBAS), 15)
1042 TPR = IAND (IPMEM(TRBAS), 15)
1043 C TPL,TPR - POLA T TYPOW BAZOWYCH LEWEJ I PRAWEJ STRONY
1044 IF ((TLDIM .NE. 0) .OR. (TRDIM .NE. 0)) GOTO 1000
1045 C SKOK DO POROWNYWANIA TYPOW TABLICOWYCH
1047 GOTO (9000, 100, 100, 200, 100, 300, 100, 400, 9100, 500,
1048 X 800, 700, 9000, 300), TPL
1050 C-----TPL JEST TYPEM KLASOWYM LUB SYSTEMOWYM
1052 GOTO (9000, 110, 110, 120, 110, 130, 110, 9000, 9100, 9000,
1053 X 9000, 9000, 9000, 120), TPR
1054 C....... TPR JEST TEZ TYPEM KLASOWYM LUB SYSTEMOWYM
1055 110 IF ((TRBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRCOR)) RETURN
1056 IF ((TRBAS .EQ. NRPROC) .OR. (TLBAS .EQ. NRPROC)) RETURN
1057 C PRZYPADEK, GDY OBA TYPY SA TYPAMI KLASOWYMI - WOWCZAS ICH
1058 C SEKWENCJE PREFIKSOWE NIE MOGA BYC ROZLACZNE
1059 IF ( MPRFSQ(TRBAS,TLBAS) .GE. 0) RETURN
1060 C ROZLACZNE SEKWENCJE PREFIKSOWE PONIZEJ
1064 C....... TPR JEST TYPEM UNIWERSALNYM LUB TYPEM NONE
1067 C....... TPR JEST TYPEM FORMALNYM
1072 C----- TPL JEST TYPEM UNIWERSALNYM, WTEDY POROWNANIE JEST ZAWSZE
1073 C POPRAWNE - O ILE TPR NIE JEST TYPEM TEKSTOWYM
1075 IF (TRBAS .EQ. NRTEXT) GOTO 700
1078 C----- TPL JEST TYPEM FORMALNYM LUB TYPEM NONE - BY ZACHODZILA ZGODNOSC
1079 C TO TPR MUSI BYC TYPEM FORMALNYM, KLASOWYM, SYSTEMOWYM, UNIWER-
1082 IF ( (TPL .EQ. 14) .OR. (TPR .EQ. 14) ) CASE = 5
1083 C-----JESLI POROWNANIE NONE Z FILE
1084 IF ((TPL .EQ. 14) .AND. (TPR .EQ. 11)) RETURN
1085 IF (TPR .GE. 13) RETURN
1086 IF (TPR .GE. 8) GOTO 9000
1087 IF (TPR .EQ. 6) GOTO 8000
1088 IF (TPR .GE. 1) RETURN
1091 C----- TPL JEST TYPEM ARYTMETYCZNYM, WTEDY TPR TEZ MUSI BYC ARYTMETYCZNE
1093 400 IF ((TRBAS .NE. NRINT) .AND.
1094 X (TRBAS .NE. NRRE) .AND.
1095 X (TRBAS .NE. NRUNIV)) GOTO 9000
1097 cdsw IF ((TPR .EQ.TPL) .AND. (TRBAS .EQ.NRINT)) CASE = 1
1098 IF ((trbas .EQ. tlbas) .AND. (TRBAS .EQ. NRINT) ) CASE = 1
1101 IF (CASE .EQ. 1) RETURN
1102 IF (TLBAS .EQ. NRINT) CONVL = 1
1103 IF (TRBAS .EQ. NRINT) CONVR = 1
1106 C-----TPL JEST TYPEM BOOLEAN LUB CHARACTER, WTEDY TPR MUSI BYC ROWNIEZ
1107 C BOOLEAN LUB CHARACTER (LUB UNIWERSALNY)
1108 500 IF ((TRBAS .EQ. NRCHR) .OR. (TLBAS .EQ. NRCHR)) GOTO 600
1110 IF ((TRBAS .EQ. NRBOOL) .OR. (TRBAS .EQ. NRUNIV)) RETURN
1113 C-----TPL JEST TYPEM CHAR, WTEDY TPR MUSI BYC BADZ CHAR BADZ UNIWER-
1116 IF ((TRBAS .EQ. NRCHR) .OR. (TRBAS .EQ. NRUNIV)) RETURN
1119 C-----TPL JEST TYPEM TEKSTOWYM, NIEZALEZNIE OD TPR JEST TO BLAD
1122 IF (TRBAS .EQ. NRTEXT) CALL MERR(608, IDR)
1125 C-----TPL - FILE. TPR MUSI BYC FILE LUB UNIWERSALNY LUB NONE
1127 IF ((TPR .EQ. 11) .OR. (TRBAS .EQ. NRUNIV)
1128 X .OR. (TRBAS .EQ. NRNONE)) RETURN
1132 C----- POROWNYWANIE TYPOW TABLICOWYCH
1134 IF (TLDIM-TRDIM) 2000, 3000, 4000
1135 C...... PRZYPADEK TLDIM < TRDIM
1136 C WOWCZAS POPRAWNE JEDYNIE, GDY TLBAS JEST FORMALNY, UNIWERSALNY
1138 C W PRZYPADKU, GDY OBA TYPY SA TYM SAMYM TYPEM FORMALNYM MUSZA
1139 C POCHODZIC Z ROZNYCH OBIEKTOW
1140 2000 IF ((TPL .EQ. 4) .OR. (TPL .EQ. 14)) RETURN
1141 IF (TPL .NE. 6) GOTO 9000
1142 C KONTROLA, GDY CO NAJMNIEJ JEDENz JEST FORMALNY
1145 C...... PRZYPADEK TLDIM = TRDIM
1147 C - OBA TYPY BAZOWE SA ROWNE
1148 C LUB - CO NAJMNIEJ JEDEN Z NICH JEST FORMALNY LUB UNIWERSALNY
1149 3000 IF ( (TPR .EQ. 4) .OR. (TPL .EQ. 4) ) RETURN
1150 IF ( (TPR .EQ. 6) .OR. (TPL .EQ. 6) ) GOTO 8000
1151 C SKOK, GDY CO NAJMNIEJ JEDEN TYP BAZOWY JEST FORMALNY
1152 IF (TRBAS .EQ. TLBAS) RETURN
1155 C...... PRZYPADEK TLDIM > TRDIM
1156 C POPRAWNE GDY TRBAS JEST FORMALNY, UNIWERSALNY LUB NONE -
1157 C DALSZE UWAGI JAK PRZY TLDIM < TRDIM
1158 4000 IF ((TPR .EQ. 4) .OR. (TPR .EQ. 14)) RETURN
1159 IF (TPR .NE. 6) GOTO 9000
1163 C------ USTALENIE RODZAJU ZGODNOSCI TYPOW REFERENCYJNYCH, GDY CO
1164 C NAJMNIEJ JEDEN Z NICH JEST TYPEM FORMALNYM
1169 IF ( MTPCON(Z) ) 8200, 8200, 8100
1170 C MTPCON PRZYJMUJE NASTEPUJACE WARTOSCI
1171 C -1 - TYP TEN SAM Z ROZNYCH OBIEKTOW
1173 C +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU
1178 C...... UZTALENIE ZGODNOSCI TYPOW TABLICOWYCH - JEDEN Z NICH
1184 IF ( MTPCON(Z) .NE. 1) RETURN
1185 C WPP - SYGNALIZACJA BLEDOW - NIE MA PODSTAWIENIA UNIFIKU-
1190 C------ SYGNALIZOWANIE BLEDOW
1192 IF (TPR .EQ. 9) GOTO 9100
1193 IF ((TRDIM .EQ. 0) .AND. (TRBAS .EQ. NRTEXT)) CALL MERR(608,
1197 C --- SYGNALIZACJA BLEDOW - NIEDOZWOLONE UZYCIE SEMAFORA
1199 IF (TPL .EQ. 9) CALL MERR(636, IDL)
1200 IF (TPR .EQ. 9) CALL MERR(636, IDR)
1204 INTEGER FUNCTION MPKIND (ATTRAD)
1205 C-------------FUNKCJA OKRESLAJACA RODZAJ KOLEJNEGO PARAMETRU
1207 C / WARTOSCIA PARAMETRU ATTRAD JEST IDENTYFIKATOR
1208 C (INDEKS W IPMEM) OPISU TEGO PARAMETRU
1209 C / ZMIENNA NRPAR (Z BLOKU /SEMANT/) MA WARTOSC ROWNA
1210 C NUMEROWI PARAMETRU WEWNATRZ LISTY PARAMETROW FORMAL-
1212 C / WARTOSC FUNKCJI OKRESLA RODZAJ PARAMETRU FORMALNEGO
1219 C // FUNKCJA KORZYSTA Z PROCEDURY MNOPF
1220 C SYGNALIZOWANY BLAD
1221 C 622 (Z MNOPF) - ZA KROTKA LISTA PF
1223 C OPIS W DOKUMENTACJI: ?3.4.3.2
1224 C WERSJA Z DNIA: 19.01.82
1226 C.............................................................................
1228 IMPLICIT INTEGER (A-Z)
1234 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1238 COMMON /MCALLS/ CLLREC, UNICLL
1240 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
1245 IF (MNOPF(0)) RETURN
1247 C*****************************************************************************
1248 C PARAMETR ZOSTAL POBRANY
1249 ATTRAD = IPMEM(CLLREC+5)
1250 ATTRAD = IPMEM(ATTRAD)
1251 NRPAR = IPMEM(CLLREC+4)
1252 C------ ROZPOZNANIE BIEZACEGO PARAMETRU
1253 C ZW - SLOWO ZEROWE OPISU PARAMETRU
1255 ZW = IAND (ISHFT(ZW, -4), 15) +1
1256 GOTO (1000, 100, 200, 300, 1000, 400, 500, 1000,
1259 C...... TYP FORMALNY
1282 C*****************************************************************************
1284 1000 IPMEM(CLLREC+7) = MPKIND
1288 SUBROUTINE MPARTP (ATDIM, ATBASE, OB, IDBASE)
1289 C-------------PRZETWARZANIE PARAMETRU AKTUALNEGO BEDACEGO TYPEM
1290 C DO REKORDU KONTROLI WPISUJE SIE INFORMACJE O TYPIE
1291 C AKTUALNYM ZASTEPUJACYM TYP-PARAMETR FORMALNY.
1292 C ATDIM, ATBASE - LICZBA ARRAY OF I TYP BAZOWY AKTUALNY
1293 C OB - NUMER OBIEKTU Z CIAGU SL, Z KTOREGO JEST POBIERANY
1294 C LUB ZERO, GDY NIE JEST DOSTEPNY PRZEZ DISPLAY
1295 C IDBASE - NAZWA ZE SCANNERA TYPU BAZOWEGO (DO SYGNALIZACJI
1298 C SYGNALIZOWANE BLEDY
1299 C 624 - TYP AKTUALNY NIE JEST REFERENCYJNY
1300 C 625 - ATBASE NIE JEST TYPEM
1301 C 637 - 'SEMAPHORE' NIE MOZE BYC TYPEM AKTUALNYM
1303 C /PROCEDURA TWORZY NOWA CZWORKE TYPOW DO MODYFIKACJI
1305 C OPIS W DOKUMENTACJI: ?3.5
1306 C WERSJA Z DNIA: 19.01.82
1308 C.............................................................................
1310 IMPLICIT INTEGER (A-Z)
1315 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1319 COMMON /MCALLS/ CLLREC, UNICLL
1321 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
1324 C...... POWROTY DLA WYWOLANIA NIEKONTROLOWANEGO
1326 IF (IPMEM(CLLREC+7) .EQ. 0) RETURN
1328 C------UTWORZENIE NOWEJ CZWORKI W REKORDZIE KONTROLI
1332 C...... ZAPIS NUMERU TYPU FORMALNEGO
1333 PF = IPMEM(CLLREC+5)
1334 IPMEM(K) = IPMEM(PF)
1335 C...... ZAPIS INFORMACJI O TYPIE AKTUALNYM
1339 C...... KONTROLA, CZY TYP AKTUALNY JEST DOPUSZCZALNY
1340 100 PF = IPMEM(ATBASE)
1342 C PF - POLE T Z OPISU TYPU ATBASE
1343 IF (PF .EQ. 1) GOTO 200
1344 C ... ATBASE NIE JEST TYPEM
1345 IF (PF .EQ. 9) GOTO 210
1346 IF (ATDIM .NE. 0) RETURN
1347 C ---TYPY TABLICOWE SA REFERENCYJNE
1348 IF (PF .LE. 7) RETURN
1349 C ---POWROT DLA POZOSTALYCH TYPOW REFERENCYJNYCH
1351 C------SYGNALIZACJA BLEDU - TYP AKTUALNY NIE JEST REFERENCYJNY
1352 CALL MERR(624, IDBASE)
1355 C------SYGNALIZACJA BLEDU- PARAMETR ATBASE NIE JEST TYPEM
1356 200 CALL MERR(625, IDBASE)
1360 C-----PARAMETREM JEST TYP 'SEMAPHORE' - BLAD
1361 210 CALL MERR(637, 0)
1365 SUBROUTINE MREPTP (TDIM, TBAS, OB)
1366 C-------------PROCEDURA MODYFIKUJE TYP (TDIM, TBAS) PRZEZ
1367 C ZASTAPIENIE EWENTUALNEGO TYPU FORMALNEGO TYPEM AKTUALNYM
1368 C JEMU ODPOWIADAJACYM.
1369 C TDIM, TBAS - OKRESLA ROWNIEZ TYP PO MODYFIKACJI
1370 C DANE DOTYCZACE DOSTEPNOSCI : OB
1371 C /PROCEDURA UZYWANA JEDYNIE, GDY WYWOLANIE JEST KONTROLO-
1374 C OPIS W DOKUMENTACJI: ?3.6.1
1375 C WERSJA Z DNIA: 19.01.82
1377 C.............................................................................
1379 IMPLICIT INTEGER (A-Z)
1384 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1388 COMMON /MCALLS/ CLLREC, UNICLL
1390 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
1392 C K - INDEKS PIERWSZEJ PIATKI TYPOW ZASTEPOWANYCH
1393 C L - INDEKS OSTATNIEJ PIATKI TYPOW ZASTEPOWANYCH
1396 C...... SPRAWDZENIE, CZY LISTA TYPOW NIE JEST PUSTA
1397 IF (K .GT. L) RETURN
1398 C------ SZUKANIE W NIEPUSTEJ LISCIE
1400 10 IF (IPMEM(K) .EQ. TBAS) GOTO 20
1401 C ---SKOK, GDY TYP JEST ODNALEZIONY
1402 IF (K .EQ. L) RETURN
1403 C ---POWROT, GDY TYP NIE WYSTEPUJE W LISCIE
1407 C------ TYP ODNALEZIONY
1408 20 TDIM = TDIM + IPMEM(K+1)
1414 SUBROUTINE MCALLO (NRPROT, IDPROT, OB, KIND)
1415 C-------------PROCEDURA OTWIERA REKORD KONTROLI STATYCZNEJ NOWEGO
1416 C WYWOLANIA (WKLADAJAC NA STOS), INICJUJE TEN REKORD
1417 C PARAMETRY WEJSCIOWE
1418 C NRPROT - NUMER WYWOLYWANEGO PROTOTYPU
1419 C IDPROT - NAZWA ZE SCANNERA WYWOLYWANEGO PROTOTYPU
1420 C OB - NUMER OBIEKTU Z CIAGU SL, Z KTOREGO WYWOLYWANY
1422 C PARAMETR WYJSCIOWY
1424 C = 0 ZWYKLY PROTOTYP
1428 C OPIS W DOKUMENTACJI: ?3.4.2
1429 C WERSJA Z DNIA: 19.01.82
1431 C.............................................................................
1433 IMPLICIT INTEGER (A-Z)
1440 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1444 COMMON /MCALLS/ CLLREC, UNICLL
1446 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
1448 COMMON /MID/ PSTART, CHECKS
1450 C------ UTWORZENIE REKORDU DLA WYWOLANIA UNIWERSALNEGO
1455 RECORD = MGETM(2, 0)
1456 IPMEM(RECORD) = CLLREC
1459 IF (NRPROT .EQ. NRUNIV) RETURN
1460 C------ UTWORZENIE REKORDU DLA WYWOLANIA KONTROLOWANEGO
1463 RECORD = MGETM(7, 0)
1465 C...... INICJALIZACJA SLOW REKORDU
1466 C RECORD - ZEROWE SLOWO WYWOLYWANEGO REKORDU
1467 RECORD = IPMEM(NRPROT)
1468 IPMEM(CLLREC) = NRPROT
1469 IPMEM(CLLREC+1) = IDPROT
1470 C...... ZBADANIE, CZY TO JEST PROTOTYP WIRTUALNY
1472 IF (BTEST(RECORD, 11) ) GOTO 100
1473 C...... ZBADANIE, CZY TO PROTOTYP FORMALNY
1474 C (PRZY POMOCY POLA ZP)
1476 ZP = IAND(ISHFT(RECORD, -4), 15)
1477 IF ( ZP .NE. 0) KIND = 2
1478 C --- ZBADANIE, CZY TO NIE JEST SYGNAL
1479 IF (ZP .EQ. 11) KIND = 0
1480 100 IPMEM(CLLREC+2) = KIND
1481 C...... INICJALIZACJA DALSZYCH SLOW
1482 IPMEM(CLLREC+3) = OB
1483 C...... WYPELNIENIE INFORMACJI O LISCIE PARAMETROW
1484 IPMEM(CLLREC+4) = -1
1485 IPMEM(CLLREC+5) = IPMEM(NRPROT+3) - 1
1486 IPMEM(CLLREC+6) = IPMEM(CLLREC+5) + IPMEM(NRPROT+4)
1487 C...... SKROCENIE LISTY PF DLA FUNKCJI - OSTATNI ELEMENT JEST
1489 RECORD = IAND( ISHFT(RECORD, -8), 7)
1490 IF (RECORD .EQ. 2) IPMEM(CLLREC+6) =
1496 C-------------ZAKONCZENIE KONTROLI WYWOLANIA, ZBADANIE
1497 C ZGODNOSCI LICZBY PARAMETROW FORMALNYCH I PARAME-
1499 C ZDJECIE REKORDU KONTROLI ZE STOSU
1500 C SYGNALIZOWANY BLAD
1501 C 623 - LISTA PF JEST DLUZSZA OD LISTY PARAMETROW
1504 C OPIS W DOKUMENTACJI: ?3.4.4.2
1505 C WERSJA Z DNIA: 19.01.82
1507 C.............................................................................
1510 IMPLICIT INTEGER (A-Z)
1516 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1520 COMMON /MCALLS/ CLLREC, UNICLL
1522 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
1524 COMMON /MID/ PSTART, CHECKS
1528 IF (UNICLL) GOTO 1000
1530 C****** KONTROLA DLUGOSCI LIST PF I PA
1531 IF (IPMEM(CLLREC+5) .EQ. IPMEM(CLLREC+6) ) GOTO 1000
1532 C --- SYGNALIZACJA BLEDU
1533 CALL MERR(623, IPMEM(CLLREC+1) )
1535 C****** ZDJECIE REKORDU ZE SZCZYTU STOSU
1536 1000 LPML = CLLREC-1
1537 CLLREC = IPMEM(CLLREC-1)
1539 IF (IPMEM(CLLREC) .EQ. 0) UNICLL = .TRUE.
1543 LOGICAL FUNCTION MNOPF (X)
1544 C-------------FUNKCJA SLUZY DO POBRANIA NOWEGO PARAMETRU
1545 C KONTROLUJE, CZY JEST TO MOZLIWE
1546 C //PRZYJMUJE WARTOSC .TRUE. GDY LISTA PF JEST PUSTA,
1547 C SYGNALIZUJE WOWCZAS (O ILE WYWOLYWANY PROTOTYP NIE
1548 C MIAL USZKODZONEJ LISTY) BLAD
1549 C ZMIENIA WYWOLANIE NA NIEKONTROLOWANE
1550 C //GDY LISTA PF NIE JEST PUSTA
1551 C AKTUALIZUJE SLOWA 5 I 6 W REKORDZIE KONTROLI
1552 C //// X - PARAMETR NIEISTOTNY
1553 C SYGNALIZOWANY BLAD
1554 C 622 - LISTA PF KROTSZA OD LISTY PARAMETROW AKTUALNYCH
1556 C OPIS W DOKUMENTACJI: ?3.4.3.1
1557 C WERSJA Z DNIA: 19.01.82
1559 C.............................................................................
1561 IMPLICIT INTEGER (A-Z)
1568 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1572 COMMON /MCALLS/ CLLREC, UNICLL
1574 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
1580 C****** MODYFIKACJA NUMEROW PARAMETRU FORMALNEGO I ELEMENTU LISTY
1581 IPMEM(CLLREC+4) = IPMEM(CLLREC+4) + 1
1582 IPMEM(CLLREC+5) = IPMEM(CLLREC+5) + 1
1583 C------ KONTROLA DLUGOSCI LISTY PF I PA
1584 IF (IPMEM(CLLREC+5) .LE. IPMEM(CLLREC+6) ) RETURN
1586 C****** PRZYPADEK, GDY NIE MA JUZ POTRZEBNEGO PF
1587 C -SYGNALIZACJA BLEDU, GDY WYWOLYWANY PROTOTYP NIE JEST
1589 C -SKROCENIE REKORDU KONTROLI STATYCZNEJ DO WYWOLANIA UNIWERSAL-
1594 C ZW - SLOWO ZEROWE PROTOTYPU
1597 C ---SKOK DLA USZKODZONEJ LISTY
1598 IF (BTEST(ZW, 13)) GOTO 100
1600 C------ SYGNALIZACJA BLEDU
1601 CALL MERR(622, IPMEM(CLLREC+1))
1602 C------ SKROCENIE REKORDU KONTROLI
1608 C-------------PROCEDURA ZASTEPUJACA WYWOLANIE KONTROLOWANE
1609 C WYWOLANIEM OBIEKTU UNIWERSALNEGO
1610 C / JEST WYKONYWANA, GDY W WYWOLANIU BYLY BLEDY UNIE-
1611 C MOZLIWIAJACE DALSZA POPRAWNA ANALIZE
1613 C OPIS W DOKUMENTACJI: ?3.4.4.1
1614 C WERSJA Z DNIA: 19.01.82
1616 C.............................................................................
1618 IMPLICIT INTEGER (A-Z)
1624 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1628 COMMON /MCALLS/ CLLREC, UNICLL
1630 C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !!
1638 INTEGER FUNCTION MTPCON (X)
1639 C X - "SLEPY" PARAMETR
1640 C-------------POMOCNICZA FUNKCJA DO KONTROLI TYPOW FORMALNYCH.
1641 C OKRESLA, CZY TYPY TRBAS I TLBAS ATRYBUTOW POCHODZACYCH
1642 C Z OBIEKTOW/WARSTW PRFXR I PRFXL (DOSTEPNYCH PRZEZ DISPLAY
1643 C ODPOWIEDNIO TE WARTOSCI SA WIEKSZE OD ZERA) SA TYM SAMYM
1646 C -1 - TYP TEN SAM, Z ROZNYCH OBIEKTOW
1648 C +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU
1650 C OPIS W DOKUMENTACJI: ?2.2.3
1651 C WERSJA Z DNIA: 19.01.82
1653 C.............................................................................
1655 IMPLICIT INTEGER (A-Z)
1661 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1663 C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON
1664 COMMON /MTPC/ PRFXR, PRFXL
1666 C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !!
1668 C......KOMUNIKACJA Z PROCEDURA MOBJFD
1670 COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
1672 C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !!
1674 C*******************************************
1675 C WARUNKI DOSTATECZNE NA TO BY TYP POCHODZIL Z TEGO
1677 C - OBYDWA ATRYBUTY SA DOSTEPNE PRZEZ DISPLAY
1678 C ORAZ JEDEN Z PONIZSZYCH
1679 C (A) POCHODZA Z TEJ SAMEJ WARSTWY (TEN SAM NUMER
1681 C (B) OBIEKTY W CIAGU SL DLA PROTOTYPU AKTUALNEGO,
1682 C Z KTORYCH POCHODZA TYPY, SA ROWNE DLA OBYDWU
1683 C ATRYBUTOW ORAZ W LANCUCHU SL OD PROTOTYPU
1684 C AKTUALNEGO DO TEGO OBIEKTU NIE WYSTEPUJA ZADNE
1685 C KLASY (NATOMIAST SAME OBIEKTY MOGA BYC KLASAMI)
1686 C (C) WYSTARCZY, BY ATRYBUTY BYLY WLASNE W OBIEKTACH
1687 C W CIAGU SL DLA PROTOTYPU AKTUALNEGO ORAZ POMIEDZY
1688 C TYMI OBIEKTAMI NIE WYSTEPUJA ZADNE KLASY ( ORAZ
1689 C OBIEKT Z TYPEM JEST TEN SAM)
1690 C (D) ATRYBUTY SA LOKALNE W PROTOTYPIE AKTUALNYM
1691 C (E) TYP NIE JEST ATRYBUTEM KLASY
1692 C********************************************
1695 IF (TRBAS .NE. TLBAS) RETURN
1697 IF ( (PRFXR .LE. 0) .OR. (PRFXL .LE. 0) ) RETURN
1698 C********************************************
1699 C BADANIE WARUNKOW (A) - (E)
1701 IF (PRFXR .EQ. PRFXL) RETURN
1702 C --POWROT DLA PRZYPADKU (A)
1703 SLOBR = IPMEM(TRBAS - 1)
1704 IF (IPMEM(SLOBR) .GT. 15) RETURN
1705 C --POWROT DLA PRZYPADKU (E)
1706 C......ODNALEZIENIE W LANCUCHU SL DLA PROTOTYPU AKTUALNEGO
1707 C P OBIEKTOW "PREFIKSOWANYCH" PRZEZ PROTOTYPY PRFXL I
1715 C SLOB - OBIEKTY W LANCUCHU SL
1716 C WCL1 = .TRUE. GDY POMIEDZY P A DRUGIM Z TYCH OBIEKTOW
1718 C WCL2 = .TRUE. GDY POMIEDZY TYMI OBIEKTAMI WYSTEPUJE
1720 IF ( (SLOBR .EQ. P) .AND. (SLOBL .EQ. P) ) RETURN
1721 C --POWROT DLA PRZYPADKU (D)
1725 C --POMIEDZY OBIEKTAMI WYSTAPILA KLASA
1727 C......TESTOWANIE PRZYPADKU (C)
1728 IF ( (PRFXR .NE. SLOBR) .OR. (PRFXL .NE. SLOBL) )
1731 PRFX1 = IPMEM(TRBAS-1)
1737 PRFX1 = IPMEM(TLBAS-1)
1741 IF (OBTPR .NE. OBTPL) RETURN
1744 C......TESTOWANIE PRZYPADKU (B)
1745 C ODSZUKANIE OBIEKTOW, Z KTORYCH BRANY JEST TYP, GDY
1746 C OTOCZENIAMI SA SLOB
1747 100 IF (WCL1) RETURN
1748 IF (IAND(IPMEM(P), 15) .NE. 1) RETURN
1749 C BY TYP NA PEWNO POCHODZIL Z TEGO SAMEGO OBIEKTU - P NIE MOZE BYC
1752 PRFX1 = IPMEM(TRBAS-1)
1756 IF (WCL1 .AND. (SLOBR .NE. OBTPR) ) RETURN
1758 PRFX1 = IPMEM(TLBAS-1)
1762 IF (WCL1 .AND. (SLOBL .NE. OBTPL) ) RETURN
1763 IF (OBTPL .NE. OBTPR) RETURN
1764 C --TYP BRANY Z ROZNYCH OBIEKTOW
1769 LOGICAL FUNCTION MDISTP (VSL, NRPROT, NRDIS)
1770 C-------------FUNKCJA SPRAWDZA, CZY TYP FORMALNY OBIEKTU DOSTEPNEGO
1771 C PRZEZ DISPLAY Z PROTOTYPU AKTUALNEGO JEST ROWNIEZ
1772 C DOSTEPNY PRZEZ DISPLAY
1773 C VSL - NUMER PROTOTYPU Z DEKLARACJA OBIEKTU
1774 C NRPROT - NUMER PROTOTYPU TYPU FORMALNEGO
1775 C /WYNIKI : NRDIS IDENTYFIKATOR PROTOTYPU, KTOREGO
1776 C NUMER W DISPLAY-U TWORZY ADRES NRPROT
1778 C - .TRUE. - TYP ZAWSZE DOSTEPNY PRZEZ DISPLAY
1779 C - .FALSE. - TYP NIE JEST LUB NIE ZAWSZE JEST DOSTEPNY
1782 C OPIS W DOKUMENTACJI: ?1.4.4
1783 C WERSJA Z DNIA: 19.01.82
1785 C.............................................................................
1788 IMPLICIT INTEGER (A-Z)
1791 cdsw DATA MDISTPHX /Z0FFF/
1797 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1799 C......KOMUNIKACJA Z PROCEDURA MOBJFD
1801 COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
1803 C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !!
1805 cdsw ---------------------
1806 data mdishx / x'0fff'/
1807 cdsw -----------------------
1808 TPSL = IPMEM(NRPROT - 1)
1810 C WARSTWA, Z KTOREJ POCHODZI TYP NRPROT
1812 IF (VSL .EQ. TPSL) RETURN
1813 IF (IAND(IPMEM(TPSL), mdishx ) .GT. 15) RETURN
1814 C OBYDWIE WIELKOSCI POCHODZA Z TEJ SAMEJ WARSTWY LUB TYP NIE
1815 C JEST ATRYBUTEM KLASY
1817 C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO
1818 C OBIEKTU Z WARSTWA VSL
1825 C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO
1826 C OBIEKTU Z WARSTWA TPSL
1832 IF (TOB .EQ. VOB) GOTO 100
1835 C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU VOB OBIEKTU
1842 IF ( TOB .NE. TOBPR) GOTO 300
1843 IF ( .NOT. WCL) GOTO 200
1845 IF (VOB .NE. TOB) RETURN
1854 300 IF (IAND(IPMEM(VOB),15) .NE. 1) RETURN
1856 IF (IAND(IPMEM(P), 15) .NE. 1) RETURN
1857 IF (IAND(IPMEM(TOBPR), 15) .EQ. 1) GOTO 200
1858 IF (BPREF(TOB, IPMEM(TOBPR-6))) RETURN
1860 C JESLI P I VOB NIE SA KLASAMI ORAZ TOB NIE JEST ROWN TOBPR A TALZE
1861 C POMIEDZY VOB A TOBPR NIE MA KLAS - TYP JEST WIDOCZNY PRZEZ DISPLAY
1862 C DODATKOWY WARUNEK: TOB NIE MOZE BYC PREFIKSOWANE PRZEZ TOBPR
1866 C POMOCNICZA PROCEDURA PRZY KONTROLI TYPOW.
1867 C WYSZUKUJE W LANCUCHU SL OBIEKTU STOB OBIEKTY
1868 C "PREFIKSOWANE" (LUB ROWNE) PRZEZ PRFX1 I PRFX2
1869 C (JESLI PRFX2=0 TO TYLKO PRFX1)
1870 C SLOB1 - OBIEKT ZAWIERAJACY WARSTWE PRFX1
1871 C SLOB2 - OBIEKT ZAWIERAJACY WARSTWE PRFX2
1872 C WCL1 = .TRUE. JESLI POMIEDZY STOB A TYMI OBIEKTAMI
1874 C WCL2 = .TRUE. JESLI POMIEDZY TYMI OBIEKTAMI WYSTE-
1877 C OPIS W DOKUMENTACJI: ?1.4.3
1878 C WERSJA Z DNIA: 19.01.82
1880 C.............................................................................
1882 IMPLICIT INTEGER (A-Z)
1883 LOGICAL WCLPR, NOCL1, NOCL2, BPREF
1884 cdsw DATA MOBJFDHX /Z0FFF/
1889 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
1891 C......KOMUNIKACJA Z PROCEDURA MOBJFD
1893 COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
1895 C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !!
1897 cdsw -------------------
1898 data mobjhx / x'0fff'/
1899 cdsw ---------------------
1900 C......INICJALIZACJA
1902 C -OBIEKT AKTUALNY W LANCUCHU SL
1906 C......SPRAWDZENIE, CZY PRFX SA KLASAMI JESLI TAK TO POBRANIE
1907 C ICH NUMEROW W SENSIE ZBIOROW PREFIKSOW
1910 ZWORD = IAND(IPMEM(PRFX1), 15)
1911 IF ( (ZWORD .GE. 15) .OR. (ZWORD .EQ. 1) )
1914 PRFN1 = IPMEM(PRFX1-6)
1915 C --PRFN1 - NUMER W SENSIE PREFXSET
1917 100 IF (PRFX2 .EQ. 0) GOTO 3000
1918 C --SKOK DO WYSZUKIWANIA PROTOTYPU Z WARSTWA PRFX1
1921 IF ( (IPMEM(PRFX2) .GE. 15) .OR. (IPMEM(PRFX2) .EQ. 1) )
1924 PRFN2 = IPMEM(PRFX2-6)
1927 IF (PRFX1 .EQ. PRFX2) GOTO 3100
1929 C************WYSZUKIWANIE BLIZSZEGO OBIEKTU
1930 1000 IF (ACTOB .EQ. PRFX1) GOTO 2000
1931 IF (ACTOB .EQ. PRFX2) GOTO 3000
1932 IF (IPMEM(ACTOB) .EQ. 1) GOTO 1600
1933 IF ( IAND(ISHFT(IPMEM(ACTOB), -8), 7) .EQ. 7) GOTO 1600
1934 C --OMINIECIE BLOKU ZWYKLEGO I HANDLERA
1935 IF (NOCL1) GOTO 1100
1936 IF (BPREF(ACTOB,PRFN1)) GOTO 2000
1937 1100 IF (NOCL2) GOTO 1500
1938 IF (BPREF(ACTOB,PRFN2)) GOTO 3000
1939 C......POBRANIE KOLEJNEGO OBIEKTU Z LANCUCHA SL (PRZY
1940 C JEDNOCZESNYM SPRAWDZENIU, CZY NIE JEST TO KLASA)
1941 1500 IF (ACTOB .EQ. STOB) GOTO 1600
1942 IF ( IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL1 = .TRUE.
1943 1600 ACTOB = IPMEM(ACTOB-1)
1947 C******WYSZUKIWANIE DRUGIEGO OBIEKTU, W PRZYPADKU GDY
1948 C PIERWSZYM JEST ODPOWIADAJACY PRFX1
1950 IF ( (IPMEM(ACTOB) .LE. 15) .AND. (IPMEM(ACTOB) .NE. 1) )
1952 C ***BADANIE KOLEJNYCH OBIEKTOW
1954 IF (ACTOB .EQ. PRFX2) GOTO 2500
1955 IF (IPMEM(ACTOB) .EQ. 1) GOTO 2300
1956 IF (IAND(ISHFT(IPMEM(ACTOB), -8), 7) .EQ. 7) GOTO 2300
1957 IF (NOCL2) GOTO 2200
1958 IF (BPREF(ACTOB, PRFN2)) GOTO 2500
1959 2200 IF (ACTOB .EQ. SLOB1) GOTO 2300
1960 IF (IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL2 = .TRUE.
1961 2300 ACTOB = IPMEM(ACTOB-1)
1965 C ***OBIEKT DRUGI ODNALEZIONY
1967 IF ( SLOB1 .EQ. SLOB2) RETURN
1968 WCL1 = ( (WCL1 .OR. WCL2) .OR. WCLPR)
1972 C******WYSZUKIWANIE DRUGIEGO OBIEKTU W PRZYPADKU, GDY PIERWSZYM
1973 C JEST ODPOWIADAJACY PRFX2 (ROWNIEZ, GDY SZUKAMY JEDNEGO
1976 ZWORD = IAND(IPMEM(ACTOB), mobjhx )
1977 IF ( (ZWORD .LE. 15) .AND. (ZWORD .NE. 1) )
1979 C ***BADANIE KOLEJNYCH OBIEKTOW W CIAGU SL
1981 IF (ACTOB .EQ. PRFX1) GOTO 3500
1982 IF (IPMEM(ACTOB) .EQ. 1) GOTO 3300
1983 IF (NOCL1) GOTO 3200
1984 IF (BPREF(ACTOB, PRFN1)) GOTO 3500
1985 3200 IF (ACTOB .EQ. SLOB2) GOTO 3300
1986 IF (IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL2 = .TRUE.
1987 3300 ACTOB = IPMEM(ACTOB-1)
1991 C ***ODNALEZIONY DRUGI OBIEKT
1993 IF (PRFX1 .NE. PRFX2) GOTO 3600
1997 IF (SLOB1 .EQ. SLOB2) RETURN
1998 C GDY OBA PREFIKSY PREFIKSUJA PIERWSZA NAPOTKANA
1999 C KLASE TO NIE TRAKTUJEMY JEJ JAKO KLASY (TZN.
2000 C WCL1 I WCL2 SA .FALSE.
2001 WCL1 = ( (WCL1 .OR. WCL2) .OR. WCLPR)
2005 SUBROUTINE MARITH ( OP )
2006 C-------------PROCEDURA BADA POPRAWNOSC ARGUMENTOW OPERACJI ARYTME-
2008 C TYPY LEWEGO I PRAWEGO ARGUMENTU DANE SA W BLOKU /SEMANT/
2009 C PRZEZ ZMIENNE TLDIM, TLBAS ORAZ TRDIM,TRBAS .
2010 C ZMIENNE IDL I IDR (W /SEMANT/) SA IDENTYFIKATORAMI LEWE-
2011 C GO I PRAWEGO ARGUMENTU (DO SYGNALIZACJI BLEDOW).
2012 C PARAMETR OP OKRESLA RODZAJ OPERACJI:
2013 C OP = 1 - DLA +,-,* ORAZ RELACJI <,>,<=,>=
2014 C OP = 2 - DLA DIV I MOD
2015 C OP = 3 - DLA / (WYNIK ZAWSZE REAL)
2016 C NA ZMIENNA TRESLT W /SEMANT/ PODSTAWIANY JEST TYP
2018 C PROCEDURA PRZEKAZUJE INFORMACJE O KONWERSJI LEWEGO (CONVL)
2019 C I PRAWEGO (CONVR) ARGUMENTU. WARTOSCI TYCH ZMIENNYCH
2022 C 1 - INTEGER DO REAL
2023 C ----SYGNALIZOWANE BLEDY :
2024 C 604 - TYP ARGUMENTU OPERACJI LUB RELACJI NIE JEST ARYTME-
2026 C 605 - TYP ARGUMENTU DIV LUB MOD NIE JEST INTEGER
2028 C OPIS W DOKUMENTACJI: ?2.4
2029 C WERSJA Z DNIA: 19.01.82
2031 C.............................................................................
2033 IMPLICIT INTEGER (A-Z)
2039 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2042 C------ KONTROLA TYPU LEWEGO ARGUMENTU
2044 IF (TLDIM .NE. 0) GOTO 100
2045 C SKOK - GDY JEST TO TYP TABLICOWY
2046 IF ((TLBAS .EQ. NRINT) .OR. (TLBAS .EQ. NRRE) .OR.
2047 X (TLBAS .EQ. NRUNIV) ) GOTO 200
2049 C...... TYP LEWEJ STRONY NIE JEST ARYTMETYCZNY
2053 C------KONTROLA TYPU PRAWEJ STRONY
2055 IF (TRDIM .NE. 0) GOTO 300
2056 IF ((TRBAS .EQ. NRINT) .OR. (TRBAS .EQ. NRRE) .OR.
2057 X (TRBAS .EQ. NRUNIV) ) GOTO 400
2059 C......TYP PRAWEJ STRONY NIE JEST ARYTMETYCZNY
2064 C------ SPRAWDZENIE ZALEZNE OD RODZAJU OPERACJI, USTALENIE KONWERSJI
2065 400 IF (OP-2) 500, 600, 700
2067 C..... OP = 1 - OPERACJE +,-,* ORAZ RELACJE
2069 C TYP REAL JEST SILNIEJSZY OD INTEGER. PRZYJMUJE WIEC, ZE JEST
2071 IF (TL .EQ. TR) TRESLT = TL
2072 IF ((TR .EQ. NRUNIV) .OR. (TL .EQ. NRUNIV)) TRESLT = NRUNIV
2073 C TYP WYNIKU JEST JUZ USTALONY
2074 C PODANIE INFORMACJI O KONWERSJI
2076 IF (TL .NE. TRESLT) CONVL = 1
2078 IF (TR .NE. TRESLT) CONVR = 1
2081 C..... OP = 2 - OPERACJE DIV I MOD
2085 C SPRAWDZENIE, CZY TYPY ARGUMENTOW NIE SA REAL
2086 IF (TL .EQ. NRRE) CALL MERR(605, IDL)
2087 IF (TR .EQ. NRRE) CALL MERR(605, IDR)
2090 C...... OP = 3 - OPERACJA /
2091 C WYNIK MUSI BYC TYPU REAL, ARGUMENTY PODLEGAJA EWENTUALNEJ
2096 IF (TL .EQ. NRINT) CONVL = 1
2097 IF (TR .EQ. NRINT) CONVR = 1
2101 LOGICAL FUNCTION MLOCTP (TP, PROT)
2102 C-------------FUNKCJA SPRAWDZA, CZY TYP TP JEST LOKALNYM ATRYBUTEM
2105 C OPIS W DOKUMENTACJI: ?1.4.2
2106 C WERSJA Z DNIA: 19.01.82
2108 C.............................................................................
2110 IMPLICIT INTEGER (A-Z)
2117 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2120 SLTP = IPMEM(TP - 1)
2121 C SLTP - MIEJSCE DEKLARACJI TP
2122 IF (SLTP .EQ. PROT) RETURN
2124 IF ( IAND( IPMEM(SLTP), 15) .EQ. 1) RETURN
2125 C POWROT Z WARTOSCIA .FALSE. O ILE SLTP NIE MOZE PREFIKSOWAC
2127 IF ( IPMEM(PROT) .EQ. 1) RETURN
2128 IF ( IAND(ISHFT(IPMEM(PROT), -8), 7) .EQ. 7) RETURN
2130 IF ( BPREF (PROT, IPMEM(SLTP - 6) ) ) MLOCTP = .TRUE.
2134 INTEGER FUNCTION MAQUAB ( IDB )
2135 C-------------FUNKCJA BADA POPRAWNOSC KONSTRUKCJI QUA IDB .
2136 C TLDIM I TLBAS OKRESLAJA TYP WYRAZENIA PRZED QUA. IDL JEST
2137 C NAZWA TEGO WYRAZENIA UZYWANA PRZY SYGNALIZACJI BLEDOW.
2138 C IDB JEST NAZWA ZE SCANNERA WYSTEPUJACA PO QUA .
2139 C // WARTOSCIA FUNKCJI JEST PROTOTYP ODPOWIADAJACY IDB
2140 C LUB NRUNIV W PRZYPADKU BLEDOW.
2141 C NAZWA IDB JEST WYSZUKIWANA W OTOCZENIU PROTOTYPU
2142 C AKTUALNEGO (P Z BLOKU /SEMANT/).
2143 C ----SYGNALIZOWANE BLEDY
2144 C 600 (Z PROCEDURY MIDENT) - NIEDOSTEPNY IDENTYFIKATOR IDB
2145 C PODOBNIE 619 I 620
2146 C 615 - TYP PRZED QUA NIE JEST KLASA UOGOLNIONA ANI TYPEM
2148 C 616 - IDENTYFIKATOR PO QUA NIE JEST TYPEM
2149 C 617 - IDENTYFIKATOR PO QUA NIE JEST TYPEM KLASOWYM
2150 C 618 - TYP PO QUA NIE JEST W SEKWENCJI PREFIKSOWEJ Z TLBAS
2153 C OPIS W DOKUMENTACJI: ?1.5.2
2154 C WERSJA Z DNIA: 19.01.82
2156 C.............................................................................
2157 IMPLICIT INTEGER (A-Z)
2163 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2165 C ODSZUKIWANIE IDENTYFIKATORA
2166 MAQUAB = MIDENT (IDB)
2168 C......SPRAWDZENIE, CZY IDB JEST TYPEM KLASOWYM
2169 IGT = IAND ( IPMEM(MAQUAB), 15)
2170 GOTO (1000, 100, 100, 2000, 100, 200, 100, 200, 200, 200,
2171 X 200, 200, 200, 200), IGT
2173 C ...IDB JEST KLASA LUB TYPEM SYSTEMOWYM - GDY TO TYP SYSTEMOWY
2175 100 IF ( (MAQUAB .NE. NRCOR) .AND. (MAQUAB .NE. NRPROC) )
2177 C SKOK - GDY JEST TO ZWYKLY TYP KLASOWY
2179 C ...IDB NIE JEST TYPEM KLASOWYM
2180 200 CALL MERR(617, IDB)
2184 C ...IDB NIE JEST TYPEM
2185 1000 CALL MERR(616, IDB)
2188 C......BADANIE TYPU PRZED QUA
2189 2000 IF (TLDIM .NE. 0) GOTO 3000
2190 C SKOK - GDY PRZED QUA TYP TABLICOWY
2191 IGT = IAND( IPMEM(TLBAS), 15)
2192 GOTO (3000, 2100, 2100, 4000, 2100, 2200, 2100, 3000, 3000,
2193 X 3000, 3000, 3000, 3000, 3000), IGT
2195 C ...PRZED QUA TYP KLASOWY LUB SYSTEMOWY
2196 2100 IF (MAQUAB .EQ. NRUNIV) RETURN
2197 IF ( (TLBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRPROC) ) RETURN
2198 IF (MPRFSQ (TLBAS, MAQUAB) .GE. 0) RETURN
2199 C TU - GDY SEKWENCJE PREFIKSOWE TYPOW KLASOWYCH SA ROZLACZNE
2204 C ...TYP PRZED QUA JEST FORMALNY
2207 C ...TYP PRZED QUA NIE JEST ODPOWIEDNI
2208 3000 CALL MERR(615, IDL)
2213 INTEGER FUNCTION MTHIS (ID)
2214 C-------------FUNKCJA BADA POPRAWNOSC KONSTRUKCJI THIS ID, GDZIE
2215 C ID JEST NAZWA ZE SCANNERA. KONSTRUKCJA WYSTEPUJE W MODU-
2216 C LE O PROTOTYPIE AKTUALNYM P (Z BLOKU /SEMANT/).
2217 C // WARTOSCIA FUNKCJI JEST PROTOTYP ID
2218 C W PRZYPADKU BLEDU - WARTOSCIA JEST PROTOTYP UNIWERSALNY.
2219 C ----SYGNALIZOWANE BLEDY
2220 C 600 (Z PROCEDURY MIDENT) - NIEDOSTEPNY IDENTYFIKATOR ID
2221 C PODOBNIE 619 I 620
2222 C 612 - ID NIE WYSTEPUJE W SEKWENCJI PREFIKSOWEJ ZADNEGO
2223 C MODULU OBEJMUJACEGO P
2224 C 613 - ID NIE JEST NAZWA KLASY UOGOLNIONEJ
2225 C 614 - ID NIE JEST NAZWA TYPU
2227 C OPIS W DOKUMENTACJI: ?1.5.1
2228 C WERSJA Z DNIA: 19.01.82
2230 C.............................................................................
2232 IMPLICIT INTEGER (A-Z)
2239 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2243 IF (MTHIS .EQ. NRUNIV) RETURN
2245 IGT = IAND (IPMEM(MTHIS), 15)
2246 GOTO (9000, 100, 100, 9000, 100, 8000, 100, 8000, 8000,
2247 X 8000, 8000, 8000, 8000, 8000), IGT
2249 C-----PRZYPADEK, GDY ID JEST NAZWA TYPU KLASOWEGO LUB SYSTEMOWEGO
2250 C PRZEJSCIE PO SL-ACH W POSZUKIWANIU MODULU PREFIKSOWANEGO
2252 C PROT - PROTOTYP BADANY
2254 NRPRF = IPMEM(MTHIS - 6)
2255 C NRPRF - NUMER PROTOTYPU W SENSIE ZBIORU PREFIKSOW
2256 200 ZWORD = IPMEM(PROT)
2257 C ZWORD - SLOWO ZEROWE PROTOTYPU PROT - DO KONTROLI, CZY NIE
2258 C JEST TO BLOK ZWYKLY, W POZOSTALYCH PRZYPADKACH BADAMY WARUNEK
2260 IF (ZWORD .EQ. 1) GOTO 250
2261 C SKOK - OMIJA BLOK ZWYKLY
2262 IF (IAND(ISHFT(ZWORD, -8), 7) .EQ. 7) GOTO 250
2263 C SKOK - OMIJA PROTOTYP HANDLERA
2264 IF (BPREF(PROT, NRPRF) ) RETURN
2265 C POWROT JESLI PROT JEST PREFIKSOWANY PRZEZ ID
2266 250 PROT = IPMEM(PROT-1)
2267 IF (PROT .NE. NBLSYS) GOTO 200
2268 C ITEROWANIE - GDY NIE DOSZLISMY DO BLOKU SYSTEMOWEGO
2269 C.....ID NIE WYSTAPILO W SEKWENCJI PREFIKSOWEJ
2273 C.....ID WYSTAPILO JAKO PREFIKS PROTOTYPU PROT
2275 C-----ID NIE JEST NAZWA KLASY UOGOLNIONEJ
2276 8000 CALL MERR(613, ID)
2281 C-----ID NIE JEST TYPEM
2282 9000 CALL MERR(614, ID)
2287 INTEGER FUNCTION MDOT(TDIM, TBAS, IDA, ID)
2288 C-------------FUNKCJA BADAJACA POPRAWNOSC WYRAZENIA KROPKOWANEGO
2289 C TDIM, TBAS - TYP WYRAZENIA PRZED KROPKA,
2290 C IDA - IDENTYFIKATOR WYRAZENIA PRZED KROPKA (DO SYGNALIZA-
2292 C ID - NAZWA ZE SCANNERA IDENTYFIKATORA PO KROPCE.
2293 C JESLI ATRYBUT JEST DOSTEPNY - WARTOSCIA MDOT JEST JEGO
2295 C JESLI ATRYBUT JEST NIEDOSTEPNY (NIEZADEKLAROWANY LUB
2296 C "CLOSE") - WARTOSCIA (PO ZASYGNALIZOWANIU BLEDU) JEST
2297 C ATRYBUT UNIWERSALNY. JESLI ATRYBUT BYL NIEZADEKLAROWANY
2298 C - JEST ON WPROWADZANY.
2299 C ----SYGNALIZOWANE BLEDY
2300 C 601 - BLEDNY TYP PRZED KROPKA (PRYMITYWNY, FORMALNY,
2301 C SYSTEMOWY LUB TABLICOWY),
2302 C 602 - IDENTYFIKATOR PO KROPCE JEST "CLOSE", HIDDEN LUB NIE JEST
2304 C 603 - IDENTYFIKATOR PO KROPCE NIE JEST ZADEKLAROWANY,
2305 C 611 - PO KROPCE WYSTEPUJE IDENTYFIKATOR STALEJ "CONST".
2306 C 621 - PO KROPCE WYSTEPUJE IDENTYFIKATOR HIDDEN LUB SPOZA
2309 C OPIS W DOKUMENTACJI: ?1.6.1
2310 C WERSJA Z DNIA: 19.01.82
2312 C.............................................................................
2314 IMPLICIT INTEGER (A-Z)
2316 C FUNKCJA POMOCNICZA DO BADANIA, CZY JESTESMY W ZASIEGU DEKLARACJI
2322 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2325 C KOMUNIKACJA Z PROCEDURA MEMPRF
2327 C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
2330 IF (TDIM .NE. 0) GOTO 1000
2332 C------ TU TYPY NIETABLICOWE
2333 TP = IAND(IPMEM(TBAS), 15)
2334 C TP - POLE T Z OPISU TYPU TBAS
2336 GOTO (1000, 100, 100, 500, 400, 1000, 400, 1000, 1000, 1000,
2337 X 1000, 1000, 1000, 1000, 1000), TP
2339 C------ TYPY POSIADAJACE ATRYBUTY (TZN. TYPY KLASOWE)
2341 NH = IAND ( ISHFT(NM, -1), 7) + 1
2342 MDOT = MEMPRF (TBAS)
2343 IF (MDOT .NE. 0) GOTO 200
2344 C------ TU - IDENTYFIKATOR NIEZADEKLAROWANY
2346 MDOT = INSERT(ID, IPMEM(TBAS+10), 0)
2349 C------ TU - GDY IDENTYFIKATOR WYSTEPUJE (LUB BYL DODEKLAROWANY)
2350 200 IF (IPMEM(MDOT+1) .EQ. 0) GOTO 220
2351 C SKOK - IDENTYFIKATOR JEST DOSTEPNY I NIE JEST CHRONIONY
2352 IF ( IPMEM(MDOT+1) .EQ. 1 ) GOTO 300
2353 C SKOK - JESLI IDENTYFIKATOR JEST "CLOSE"
2354 IF (IPMEM(MDOT+1) .EQ. 4) GOTO 250
2355 C SKOK - JESLI IDENTYFIKATOR JEST 'NOT TAKEN'
2356 C ---TU IDENTYFIKATOR JEST 'HIDDEN'
2357 IF (.NOT. OWN) GOTO 250
2358 C ---TERAZ NALEZY SPRAWDZIC, CZY IDENTYFIKATOR NIE BYL 'CLOSE' JUZ
2360 IF (IPMEM(TBAS+19) .EQ. 0) GOTO 210
2361 C ---TBAS JEST NIEPREFIKSOWANY
2362 PRID = MEMPRF (TBAS+19)
2363 IF (PRID .EQ. 0) GOTO 210
2364 IF (IPMEM(PRID+2) .NE. IPMEM(MDOT+2)) GOTO 210
2365 C ---IDENTYFIKATOR NIE BYL DEKLAROWANY W PREFIKSIE
2366 IF (IPMEM(PRID+1) .EQ. 1) GOTO 250
2367 C ---SKOK - IDENTYFIKATOR BYL 'CLOSE' JUZ W PREFIKSIE
2368 C---SPRAWDZENIE, CZY JESTESMY W ZASIEGU DEKLARACJI MODULU CHRONIACEGO ATRYBUT
2369 210 IF (.NOT. MINSCP(TBAS)) GOTO 250
2370 220 MDOT = IPMEM(MDOT+2)
2373 C------ TU IDENTYFIKATORY "HIDDEN" LUB "NOT TAKEN"
2374 250 CALL MERR(621, ID)
2375 IF (.NOT. OWN) NRE = INSERT(ID, IPMEM(TBAS+10), 0)
2376 IF (OWN .AND. (IPMEM(MDOT+1) .LT. 4) ) GOTO 255
2378 IPMEM(MDOT+2) = NRUNIV
2383 C------ TU IDENTYFIKATORY "CLOSE" LUB STALE "CONST"
2386 IF (NM .EQ. NRUNIV) GOTO 350
2387 C --BADANIE, CZY TO STALA 'CONST'
2388 NM = ISHFT( IPMEM(NM), -4)
2390 IF (NM .NE. 8) GOTO 350
2393 350 IF (.NOT. OWN) GOTO 360
2394 IF (MINSCP(TBAS)) GOTO 220
2395 360 CALL MERR(NRE, ID)
2396 IF (.NOT. OWN) NRE = INSERT(ID, IPMEM(TBAS+10), 0)
2401 C------OBIEKTY COROUTINE LUB PROCESS
2402 400 IF ((TBAS .NE. NRCOR) .AND. (TBAS .NE. NRPROC)) GOTO 100
2404 C------NIEPOPRAWNY TYP PRZED KROPKA
2405 1000 CALL MERR(601, IDA)
2406 C------ TYP PRZED KROPKA JEST UNIWERSALNY
2411 LOGICAL FUNCTION MINSCP (T)
2412 C-----------------FUNKCJA BADA,CZY PROTOTYP AKTUALNY JEST WEWENATRZ
2413 C DEKLARACJI MODULU T, TZN. CZY T LEZY W LANCUCHU SL
2416 C....................................................................
2418 IMPLICIT INTEGER (A-Z)
2424 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2428 100 IF (PR .EQ. T) RETURN
2429 IF (PR .EQ. NBLSYS) GOTO 200
2432 200 MINSCP = .FALSE.
2437 C---------------------------------PROCEDURA POMOCNICZA - OTWIERA POMOCNICZA
2438 C STRUKTURE DANYCH PRZY WEJSCIU DO INSTRUKCJI NOWEGO
2441 C............................................................................
2443 IMPLICIT INTEGER (A-Z)
2449 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2451 COMMON /MID/ PSTART, CHECKS
2462 C---------------------------------PROCEDURA POMOCNICZA - ZAMYKA POMOCNICZA
2463 C STRUKTURE DANYCH PRZY WYJSCIU Z PROTOTYPU
2465 C........................................................................
2467 IMPLICIT INTEGER (A-Z)
2473 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2475 COMMON /MID/ PSTART, CHECKS
2482 INTEGER FUNCTION MIDENT(ID)
2483 C-------------------------------FUNKCJA WYSZUKUJE W PROTOTYPIE AKTUALNYM P
2484 C I JEGO OTOTCZENIU NAZWE ID (HASH ZE SCANNERA).
2485 C WYSZUKIWANIE ODBYWA SIE NAJPIERW W STRUKTURZE
2488 C.............................................................................
2490 IMPLICIT INTEGER (A-Z)
2496 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2498 COMMON /MID/ PSTART, CHECKS
2501 C *****SZUKANIE NAZWY W LOKALNEJ STRUKTURZE DANYCH
2502 MIDENT = MEMBER(ID, IPMEM(PSTART))
2503 IF (MIDENT .EQ. 0) GOTO 100
2504 C ----NAZWA ODNALEZIONA - NA PEWNO JEST POPRAWNA, NIE TRZEBA SYGNALIZOWAC
2506 C NALEZY JEDYNIE USTAWIC ZMIENNE INFORMUJACE O DOSTEPIE
2507 OBJECT = IPMEM(MIDENT+1)
2508 LOCAL = IPMEM(MIDENT+4)
2509 MIDENT = IPMEM(MIDENT+2)
2510 OWN = (LOCAL .LT. 0)
2511 IF (OWN) LOCAL = -LOCAL-1
2513 C ----NAZWA NIE ZOSTALA ODNALEZIONA - SZUKANIE PRZY POMOCY MIDB
2514 100 MIDENT = MIDB(ID)
2515 C ----JESLI MOZEMY WSTAWIAC DO LISTY POMOCNICZEJ, TO WSTAWIAMY, WPP POWROT
2516 IF ((LPML+5) .GT. LPMF) CHECKS = CHECKS+1
2517 IF (CHECKS .GT. 0) GOTO 200
2521 MIDENT = IPMEM(MIDENT+2)
2523 IPMEM(NADR+1) = OBJECT
2524 IPMEM(NADR+2) = MIDENT
2525 IPMEM(NADR+4) = LOCAL
2526 IF (OWN) IPMEM(NADR+4) = -(LOCAL+1)
2527 NH = IAND(ISHFT(ID, -1), 7) + PSTART
2528 IPMEM(NADR+3) = IPMEM(NH)
2531 200 MIDENT = IPMEM(MIDENT+2)
2535 INTEGER FUNCTION MIDB (ID)
2536 C-------------FUNKCJA WYSZUKUJE W PROTOTYPIE AKTUALNYM P ( /SEMANT/)
2537 C I JEGO OTOCZENIU NAZWE ID (HASH ZE SCANNERA).
2538 C (.) JESLI NAZWA TA JEST DOSTEPNA, TO :
2539 C -NADAJE ZMIENNEJ LOCAL WARTOSC
2540 C WYSTAPIENIA IDENTYFIKATORA),
2541 C -WARTOSCIA FUNKCJI JEST INDEKS OPISU TEGO IDENTYFIKA-
2543 C (.) JESLI NAZWA NIE JEST DOSTEPNA LUB JEST NIEZADEKLAROWA-
2544 C NA - DODEKLAROWUJE JA, SYGNALIZUJE BLAD I NADAJE WAR-
2545 C TOSC ATRYBUTU UNIWERSALNEGO.
2546 C ----SYGNALIZOWANE BLEDY:
2547 C 600 - NIEZADEKLAROWANY (LUB NIEDOSTEPNY) IDENTYFIKATOR
2548 C 619 - UZYCIE IDENTYFIKATORA HIDDEN
2549 C 620 - UZYCIE IDENTYFIKATORA SPOZA LISTY TAKEN
2552 C OPIS W DOKUMENTACJI: ?1.4.1
2553 C WERSJA Z DNIA: 19.01.82
2555 C.............................................................................
2556 IMPLICIT INTEGER (A-Z)
2562 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2565 MIDB = MEMSL (ID, P)
2566 C MEMSL MA WARTOSC ZERO, JESLI NAZWA NIE ZOSTALA ODNALEZIONA
2567 C LUB JEST INDEKSEM W LISCIE HASH-U.
2568 C OWN MA WARTOSC .TRUE. - GDY IDENTYFIKATOR ZOSTAL ZNALEZIONY
2569 C BEZPOREDNIOW PROTOTYPIE (A NIE JEGO PREFIKSIE) - MOZE BYC
2571 IF (MIDB .EQ. 0) GOTO 1000
2572 C------TU PRZYPADEK NAZWY ODNALEZIONEJ
2573 C...... SPRAWDZENIE DOSTEPNOSCI IDENTYFIKATORA
2574 IF ( IPMEM(MIDB + 1) .GE. 4 ) GOTO 1200
2575 C IDENTYFIKATOR NIE JEST NA LISCIE TAKEN
2576 IF ( (IPMEM(MIDB+1) .GE. 2) .AND. (.NOT. OWN) ) GOTO 1300
2577 C IDENTYFIKATOR JEST HIDDEN W KTORYMS Z PREFIKSOW
2580 C------TU PRZYPADEK NAZWY NIEODNALEZIONEJ
2581 1000 CALL MERR(600, ID)
2582 C DODEKLAROWANIE NAZWY - ELEMENTU LISTY HASH-U
2583 1100 MIDB = INSERT(ID, IPMEM(P+10), 0)
2587 C...... SYGNALIZACJE BLEDOW DLA NIEDOSTEPNYCH ATRYBUTOW
2588 1200 CALL MERR(620, ID)
2589 IF (.NOT. OWN) GOTO 1100
2591 IPMEM(MIDB+2) = NRUNIV
2593 1300 CALL MERR(619, ID)
2598 INTEGER FUNCTION MEMSL (NAME, IDPROT)
2599 C-------------WYSZUKUJE NAZWE NAME W PROTOTYPIE IDENTYFIKOWANYM PRZEZ
2600 C IDPROT ORAZ JEGO OTOCZENIU (PO SL-ACH). WARTOSCIA JEST
2601 C ELEMENT LISTY HASH-U Z TA NAZWA LUB 0 - GDY TEJ NAZWY
2603 C / JESLI NAZWA WYSTAPILA BEZPOSREDNIO W IDPROT LUB JEGO
2604 C PREFIKSACH - WARTOSCIA
2605 C ZMIENNEJ LOCAL Z BLOKU // JEST 2, WPP 0 LUB 1
2606 C / PO ODNALEZIENIU NAZWY ELEMENT PRZESUWANY NA POCZATEK
2608 C / OWN MA WARTOSC .TRUE. JESLI NAZWA ODNALEZIONA JEST
2609 C BEZPOSREDNIO W PROTOTYPIE A NIE W PREFIKSIE.
2610 C TO ZNACZY TAM WYSTEPUJE W LISCIE - DO KONTROLI PROTEKCJI.
2611 C /OBJECT - PROTOTYP OBIEKTU, W KTORYM ODNALEZIONO ATRYBUT O
2614 C OPIS W DOKUMENTACJI: B.III.2.4
2615 C WERSJA Z DNIA: 19.01.82 (MJL)
2617 C.......................................................................
2619 IMPLICIT INTEGER (A-Z)
2625 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
2628 C KOMUNIKACJA Z PROCEDURA MEMPRF
2630 C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
2633 NH = IAND( ISHFT(NAME, -1), 7) + 1
2634 C NH - WARTOSC FUNKCJI HASZUJACEJ DLA SZUKANEJ NAZWY
2638 C ISL - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW
2642 C WYSZUKUJEMY W PREFIKSACH PROTOTYPU ISL
2643 10 MEMSL = MEMPRF(ISL)
2644 IF (MEMSL .NE. 0) GOTO 20
2645 C POWROT, GDY NAZWA JUZ ODNALEZIONA
2647 C ..... NAZWA NIEODNALEZIONA W PROTOTYPIE ISL - POBRANIE NOWEGO PROTOTY-
2649 IF (ISL .EQ. NBLSYS) GOTO 1000
2650 C SKOK - JESLI DOSZLISMY DO BLOKU SYSTEMOWEGO NIE ZNAJDUJAC
2651 C NAZWY - BEDZIE TO POWROT
2656 C .... NAZWA ODNALEZIONA
2657 20 IF (ISL .EQ. NBLUS) LOCAL = 0
2660 C .... NAZWA NIEODNALEZIONA
2665 INTEGER FUNCTION MEMPRF ( IDPROT)
2666 C-------------WYSZUKUJE NAZWE NM W PROTOTYPIE IDENTYFIKOWANYM PRZEZ
2667 C IDPROT ORAZ JEGO PREFIKSACH. WARTOSCIA JEST
2668 C ELEMENT LISTY HASH-U Z TA NAZWA LUB 0 - GDY TEJ NAZWY
2670 C / JESLI NAZWA WYSTAPILA BEZPOSREDNIO W IDPROT WARTOSCIA
2671 C / ZMIENNEJ OWN JEST .TRUE., JESLI W PREFIKSACH - .FALSE.
2672 C //PO ODNALEZIENIU NAZWY ELEMENT PRZESUWANY NA POCZATEK
2674 C OPIS W DOKUMENTACJI: B.III.2.3
2675 C WERSJA Z DNIA: 19.01.82 (MJL)
2677 C.......................................................................
2680 IMPLICIT INTEGER (A-Z)
2686 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
2689 C KOMUNIKACJA Z PROCEDURA MEMPRF
2691 C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
2697 C IPR - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW
2699 IF (IPMEM(IPR) .EQ. 1) GOTO 500
2700 IF (IAND( ISHFT(IPMEM(IPR), -4), 15) .NE. 0) GOTO 500
2701 C SKOK, GDY BYL TO ZWYKLY BLOK LUB PROTOTYP FORMALNY, NIE MA
2702 C WTEDY PRZEJSCIA PO PREFIKSACH
2703 IF (IAND(ISHFT(IPMEM(IPR), -8), 7) .EQ. 7) GOTO 500
2704 C SKOK - GDY BYL TO PROTOTYP HANDLERA, NIE MA PRZEJSCIA PO PREFIKSACH
2705 C I,J - WSKAZNIKI PRZECHODZENIA PO LISCIE HASH-U - J AKTUALNY,
2711 C ..... SZUKANIE W PROTOTYPIE IPR
2712 20 IF (J.EQ.0) GOTO 25
2713 C SKOK - NAZWA NIEODNALEZIONA - POBIERAMY KOLEJNY PROTOTYP
2715 IF (IPMEM(J).EQ. NM) GOTO 100
2716 C SKOK - NAZWA ODNALEZIONA
2722 C NAZWA NIEODNALEZIONA W PREFIKSIE IPR - POBRANIE NOWEGO
2726 C PRZEJSCIE DO PREFIKSU
2728 IF (IPR .NE. 0) GOTO 10
2733 C ..... NAZWA ODNALEZIONA
2736 C MIEJSCE DEKLARACJI
2737 OBJECT = IPMEM(OBJECT-1)
2738 IF (I.NE.-1) GOTO 110
2740 C PRZESUNIECIE ELEMENTU NA POCZATEK LISTY
2741 110 IPMEM(I+3) = IPMEM (J+3)
2743 IPMEM(J+3) = IPMEM(I)
2747 C.....BLOKI ZWYKLE, HANDLERY I PROTOTYPY FORMALNE
2748 500 MEMPRF = MEMBER(NM, IPMEM(IPR+10))
2752 C .... NAZWA NIEODNALEZIONA
2757 INTEGER FUNCTION INSERT (NAME, THASH, NROVF)
2758 C-------------WPROWADZA NOWY ELEMENT O KLUCZU NAME DO TABLICY HASH-U
2759 C THASH. DZIALA POPRAWNIE POD WARUNKIEM, ZE W TABLICY ELE-
2760 C MENT TAKI JESZCZE NIE WYSTAPIL.
2761 C WARTOSCIA INSERT JEST IDENTYFIKATOR TEGO ELEMENTU.
2762 C / WARTOSCI POCZATKOWE UTWORZONEGO ELEMENTU
2764 C BITY HIDDEN, CLOSE, NOT TAKEN - 0
2765 C IDENTYFIKATOR ATRYBUTU - NRUNIV
2766 C / NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA
2768 C OPIS W DOKUMENTACJI: B.III.2.1
2769 C WERSJA Z DNIA: 19.01.82 (MJL)
2771 C.......................................................................
2773 IMPLICIT INTEGER (A-Z)
2780 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
2782 C ..... REZERWACJA PAMIECI NA ELEMENT LISTY HASH-U
2783 INSERT = MGETM(4, NROVF)
2785 C ..... NADANIE WARTOSCI POCZATKOWYCH I DOLACZENIE DO LISTY HASH-1
2786 IPMEM(INSERT) = NAME
2787 IPMEM(INSERT +2) = NRUNIV
2788 NH = IAND( ISHFT(NAME, -1), 7) + 1
2789 IPMEM(INSERT+3) = THASH (NH)
2794 INTEGER FUNCTION MEMBER (NAME, THASH)
2795 C-------------SPRAWDZA, CZY W TABLICY HASH-U THASH WYSTEPUJE NAZWA
2796 C NAME. JESLI TAK - WARTOSCIA JEST IDENTYFIKATOR ELEMENTU
2797 C LISTY HASH-U Z TA NAZWA. JESLI NIE - WARTOSCIA JEST 0 .
2798 C / JESLI NAZWA WYSTAPILA - ELEMENT JEJ ODPOWIADAJACY JEST
2799 C PRZESUWANY NA POCZATEK LISTY.
2801 C OPIS W DOKUMENTACJI: B.III.2.2
2802 C WERSJA Z DNIA: 19.01.82 (MJL)
2804 C......................................................................
2806 IMPLICIT INTEGER (A-Z)
2813 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
2814 NH = IAND( ISHFT(NAME, -1), 7) + 1
2815 C NH - WARTOSC FUNKCJI HASZUJACEJ - INDEKS W TABLICY THASH SLOWA
2816 C ZAWIERAJACEGO POCZATEK LISTY
2818 C I,J - WSKAZNIKI PORUSZANIA SIE PO LISCIE
2819 C J - WSKAZNIK AKTUALNY, I - POPRZEDNI
2823 10 IF (J.EQ.0) GOTO 200
2824 C SKOK - JESLI ATRYBUT NIE ZOSTAL ODNALEZIONY
2826 IF (IPMEM(J) .EQ. NAME ) GOTO 100
2827 C SKOK - JESLI ATRYBUT ODNALEZIONY
2832 C ..... NAZWA ODNALEZIONA
2834 IF (I.NE. -1) GOTO 110
2836 C PRZESUNIECIE ELEMENTU LISTY NA POCZATEK LISTY
2837 110 IPMEM(I+3) = IPMEM(J+3)
2838 IPMEM(J+3) = THASH(NH)
2842 C ..... NAZWA NIEODNALEZIONA
2847 INTEGER FUNCTION MGETM(ISIZE, NROVF)
2848 C-------------REZERWUJE W PAMIECI IPMEM ISIZE KOMOREK. WAROSCIA MGETM
2849 C JEST INDEKS PIERWSZEJ Z TYCH KOMOREK.
2850 C REZERWACJA JEST DOKONYWANA W CZESCI SYSTEMOWEJ JESLI WAR-
2851 C TOSC ZMIENNEJ INSYS (BLOK //) JEST .TRUE., W PRZE-
2852 C CIWNYM PRZYPADKU - W CZESCI UZYTKOWNIKA.
2853 C /// GDY REZERWACJA TA NIE JEST MOZLIWA - WYWOLYWANA JEST
2854 C PROCEDURA MDROP PRZERYWAJACA PROCES KOMPILACJI
2855 C NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA
2857 C OPIS W DOKUMENTACJI: B.III.1
2858 C WERSJA Z DNIA: 19.01.82 (MJL)
2860 C...........................................................................
2862 C ZAREZERWOWANA PAMIEC JEST WYZEROWANA
2864 IMPLICIT INTEGER (A-Z)
2870 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
2872 IF ( (LPML+ISIZE) .GT. LPMF) GOTO 1000
2873 C SKOK - GDY WOLNY OBSZAR JEST ZA MALY
2876 C ..... PRZYDZIAL PAMIECI W CZESCI UZYTKOWNIKA
2885 C ..... PRZYDZIAL PAMIECI W CZESCI SYSTEMOWEJ
2892 C.....SPRAWDZENIE WYKORZYSTANIA PAMIECI
2894 IF (X .LT. COM(4)) COM(4) = X
2898 C ..... BRAK MIEJSCA W PAMIECI
2899 1000 CALL MDROP(NROVF)
2903 INTEGER FUNCTION MPRFSQ (IDPR1, IDPR2)
2904 C-------------BADA RODZAJ PREFIKSOWANIA TYPOW IDPR1 I IDPR2
2906 C -1 - ROZLACZNE SEKWENCJE PREFIKSOWE
2907 C 0 - IDPR1 PREFIKSUJE IPR2
2908 C +1 - IDPR2 PREFIKSUJE IDPR1
2909 C OBA TYPY MOGA BYC TYPAMI UNIWERSALNYMI
2911 C OPIS W DOKUMENTACJI: B.III.4.3
2912 C WERSJA Z DNIA: 19.01.82 (MJL)
2914 C........................................................................
2916 IMPLICIT INTEGER (A-Z)
2923 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
2927 C K1,K2 - NUMERY TYPOW W SENSIE PREFIXSET
2928 IF (BPREF(IDPR2, K1)) GOTO 20
2929 IF (BPREF(IDPR1, K2)) GOTO 30
2931 C ..... ROZLACZNE SEKWENCJE PREFIKSOWE
2934 C ..... IDPR1 PREFIKSUJE IDPR2
2937 C ..... IDPR2 PREFIKSUJE IDPR1
2943 LOGICAL FUNCTION BPREF (IDPROT, NRPREF)
2944 C-------------BPREF SPRAWDZA, CZY TYP IDENTYFIKOWANY PRZEZ IDPROT JEST
2945 C PREFIKSOWANY PRZEZ KLASE, KTOREJ NUMER W SENSIE PREFIXSET
2946 C JEST ROWNY NRPREF.
2947 C WARTOSC .TRUE. - JEST PREFIKSOWANY
2950 C OPIS W DOKUMENTACJI: B.III.4.1
2951 C WERSJA Z DNIA: 19.03.82 (MJL)
2953 C.........................................................................
2955 IMPLICIT INTEGER (A-Z)
2962 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
2964 IF (NRPREF .GT. 47) GOTO 300
2966 IF ( IAND(IPMEM(IDPROT), 15) .NE. 1) GOTO 100
2968 IF (IPMEM(IDPROT+21) .EQ. 0 ) RETURN
2969 K = IPMEM(IDPROT+21) -3-K
2973 C K SLOWO W PREFIXSET, W KTORYM NALEZY ZBADAC BIT ODPOWIADAJACY
2977 C L - NUMER TESTOWANEGO BITU - L = IMOD(NRPREF,16)
2983 IF (IAND(IPMEM(IPR), 15) .EQ. 1) IPR = IPMEM(IPR+21)
2984 IF (IPR .EQ. 0) GOTO 500
2985 IF (IPR .EQ. NRUNIV) RETURN
2988 400 PRFX= IPMEM(IPR)
2989 IF (IPMEM(PRFX-6) .EQ. NRPREF) RETURN
2992 IF (IDL .NE. 0) GOTO 400
2997 SUBROUTINE MDROP(NROVFL)
2998 C-------------PROCEDURA PRZERYWA DZIALANIE MODULU.
2999 C WYWOLYWANA JEST W PRZYPADKU PRZEPELNIEN JAKIEJKOLWIEK TAB-
3001 C NROVFL - NUMER PRZEPELNIENIA (INFORMACJA O TABLICY)
3002 C //WYWOLUJE PROCEDURE MERR , BUFORY STRUMIENI PRZESYLA DO
3003 C OBSZARU KOMUNIKACYJNEGO W BLOKU //.
3004 C USTAWIA FLAGE "DROPOWANIA".
3006 C OPIS W DOKUMENTACJI: B.I.2
3007 C WERSJA Z DNIA: 19.01.82 (MJL)
3009 C......................................................................
3011 IMPLICIT INTEGER (A-Z)
3017 COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3018 C ERRFLG - FLAGA BLEDOW
3020 C SYGNALIZOWANIE BLEDU
3022 CALL MERR(NROVFL, 0)
3032 SUBROUTINE MERR(NRE, ID)
3033 C--------------PROCEDURA WPISUJACA SYGNALIZACJE BLEDOW NA STRUMIEN 2
3035 C ID - IDENTYFIKACJA BLEDU, TO ZNACZY
3036 C -IDENTYFIKATOR ZE SCANNERA,
3037 C -ZANEGOWANY ZNAK W PRAWYM BAJCIE,
3038 C -ZERO OZNACZAJACE BRAK IDENTYFIKATORA.
3039 C //PROCEDURA W RAZIE POTRZEBY NISZCZY DOTYCHCZASOWY
3040 C ZAPIS ZNAJDUJACY SIE NA STRUMIENIU SO (KOD DLA ASSEMBLERA)
3041 C ORAZ USTAWIA FLAGE BLEDOW ERRFLG.
3043 C OPIS W DOKUMENTACJI: B.I.1
3044 C WERSJA Z DNIA: 19.01.82 (MJL)
3046 C.................................................................
3048 IMPLICIT INTEGER (A-Z)
3052 COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3053 C ERRFLG - FLAGA BLEDOW
3054 C !!!!!! END OF SUBSTITUTION OF COMDECK STREAM FROM LOGLAN.14 !!
3056 COMMON /MJLMSG/ IERC, MSG
3057 C !!!!!! END OF SUBSTITUTION OF COMDECK MJLMSG FROM LOGLAN.14 !!
3059 cdeb --------------------- added =----------------
3060 common /debug/deb,breakt(500),brnr,maxbr
3062 cdeb ---------------------------------------
3065 C----- ZBADANIE, CZY JEST TO PIERWSZY SYGNALIZOWANY BLAD
3066 IF (ERRFLG) GOTO 100
3068 C..... PRZYPADEK, GDY BLAD JEST SYGNALIZOWANY PO RAZ PIERWSZY
3070 C --- L-CODE WRITTEN DIRECTLY IN THE SIEMENS VERSION
3071 C --- IN THE SIEMENS VERSION OF THE COMPILER IBUF2 IS USED ONLY
3072 C --- TO LOCATE THERE INFORMATION ABOUT ERRORS. SO NOW IT IS THE
3073 C --- PROPER TIME TO OPEN IT
3078 c --- unit 19 (ibuf2) - do bledow (direct)
3079 CALL OPENF(IBUF2,19)
3080 C OD TEJ PORY BUFOR ZACZYNA ODPOWIADAC STRUMIENIOWI O DOSTEPIE
3081 C BEZPOSREDNIM . JEGO BUDOWA:
3082 C SLOWA 1-7 -BUFOR DLA PROCEDUR ZAPISU I ODCZYTU (OPIS STRUMIENIA)
3083 C SLOWO 8 -NUMER AKTUALNIE ZAPISYWANEGO BLOKU
3084 C SLOWO 9 -INDEKS PIERWSZEJ WOLNEJ POZYCJI BLOKU AKTUALNIE TWORZO-
3086 C SLOWO 10 -LICZBA TROJEK WPISANYCH DO BLOKU
3087 C SLOWA 10-265 -AKTUALNIE TWORZONY BLOK (TROJKI ZAPISYWANE OD SLO-
3093 C-----WPISANIE SYGNALIZACJI BLEDU
3096 C POZ - AKTUALNA POZYCJA DO WYPELNIENIA
3097 C ZAPISANIE NUMERU LINII, NUMERU BLEDU I IDENTYFIKACJI
3101 C MODYFIKACJA BUFORA
3104 IF (POZ .LE. 263) RETURN
3105 C ..... JESLI BLOK ZOSTAL ZAPELNIONY, ZAPISANIE GO NA DYSK
3106 IBUF2(8) = IBUF2(8) + 1
3109 CALL PUT(IBUF2, IBUF2(10))
3113 SUBROUTINE MADATR (IDATR, IDPROT, NROVF)
3114 C-------------WPROWADZA ATRYBUT O IDENTYFIKATORZE IDATR DO LISTY ATRYBU-
3115 C TOW PROTOTYPU IDPROT. W OPISIE ATRYBUTU NADAJE WARTOSC
3116 C POLOM DECLPLACE/SL ORAZ NUMERU ATRYBUTU
3117 C // NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA
3119 C OPIS W DOKUMENTACJI: B.III.3
3120 C WERSJA Z DNIA: 19.01.82 (MJL)
3122 C.........................................................................
3124 IMPLICIT INTEGER (A-Z)
3130 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
3132 IACT = MGETM(2, NROVF)
3134 IOST = IPMEM(IDPROT+7)
3135 C IOST - OSTATNI ELEMENT LISTY ATRYBUTOW
3136 C ..... DOLACZENIE IACT DO LISTY ATRYBUTOW
3137 IPMEM(IOST+1) = IACT
3138 IPMEM(IDPROT+7) = IACT
3139 C ..... NADANIE WARTOSCI SL ORAZ NUMERU ATRYBUTU
3141 C IOST - OSTATNI ATRYBUT - INDEKS OPISU
3142 IPMEM(IDATR-1) = IDPROT
3143 IPMEM(IDATR-2) = IPMEM(IOST-2) + 1
3146 SUBROUTINE MSETB (IDPROT, NRPREF)
3147 C-------------W ZBIORZE PREFIXSET TYPU IDENTYFIKOWANEGO PRZEZ IDPROT
3148 C USTAWIA BIT NRPREF NA 1
3150 C OPIS W DOKUMENTACJI: B.III.4.2
3151 C WERSJA Z DNIA: 19.03.82 (MJL)
3153 C.......................................................................
3155 IMPLICIT INTEGER (A-Z)
3161 C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !!
3163 IF (NRPREF .GT. 47) RETURN
3166 C K - INDEKS MODYFIKOWANEGO ELEMENTU PREFIXSET
3169 C L - NUMER ZAPALANEGO BITU
3172 IPMEM(K) = IOR ( IPMEM(K), L)