C Loglan82 Compiler&Interpreter C Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw C Copyright (C) 1993, 1994 LITA, Pau C C This program is free software; you can redistribute it and/or modify C it under the terms of the GNU General Public License as published by C the Free Software Foundation; either version 2 of the License, or C (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. File: LICENSE.GNU C =============================================================== *DECK MPARPF SUBROUTINE MPARPF (PAPROT, PAID, PAOB, DCONTR) C-------------BADA ZGODNOSC PARAMETRU AKTUALNEGO (FUNKCJI/PROCEDURY) C I PARAMETRU FORMALNEGO. C PAPROT - NUMER PROTOTYPU AKTUALNEGO C PAID - JEGO IDENTYFIKATOR ZE SCANNERA C PAOB - DOSTEPNOSC PRZEZ DISPLAY C DCONTR - NADAWANA JEST WARTOSC .TRUE., GDY KONIECZNA JEST C KONTROLA DYNAMICZNA C SYGNALIZOWANE BLEDY C 626 - NIEZGODNOSC RODZAJOW PARAMETROW FORMALNEGO I AKTUAL- C NEGO (FUNKCJA<->PROCEDURA) C NIEZGODNE NAGLOWKI C 627 - NIEZGODNE RODZAJE PARAMETROW C 628 - TYPY PARAMETROW SA NIEZGODNEGO RODZAJU C 629 - TYPY PARAMETROW MAJA ROZLACZNE SEKWENCJE PREFIKSOWE C 630 - NIEZGODNE DLUGOSCI LIST C INNE C 631 - NIEZGODNE TYPY FUNKCJI AKTUALNEJ I FORMALNEJ C 632 - PARAMETR AKTUALNY NIE JEST FUNKCJA ANI PROCEDURA C 635 - PARAMETR AKTUALNY JEST FUNKCJA LUB PROCEDURA C STANDARDOWA C C OPIS W DOKUMENTACJI: ?3.7.4 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 807 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL DCONTR,BTEST C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C *CALL MPI2 C......BLOK KOMUNIKACJI PROCEDUR MPARPF ORAZ MPIO2 LOGICAL DCLASS, AFORM COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS, X AFORM C C !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14 !! C APROT = PAPROT AID = PAID AOB = PAOB C DCONTR = .TRUE. C C SPRAWDZENIE, CZY BEDZIE KONTROLA STATYCZNA IF (UNICLL) RETURN IF ( IPMEM(CLLREC+7) .EQ. 0) RETURN IF (APROT .EQ. NRUNIV) RETURN C C------ KONTROLA ZGODNOSCI RODZAJOW C PF - OPIS PARAMETRU FORMALNEGO PF = IPMEM(CLLREC+5) PF = IPMEM(PF) ZW = IPMEM(APROT) ZW = IAND ( ISHFT(ZW, -8), 7) + 1 C ZW - POLE S SLOWA ZEROWEGO PROTOTYPU AKTUALNEGO GOTO (100, 100, 200, 100, 300, 100, 100, 100), ZW C C------ TO NIE JEST ANI FUNKCJA, ANI PROCEDURA 100 CALL MERR(632, AID) RETURN C C...... PARAMETR AKTUALNY JEST FUNKCJA 200 PALGTH = -1 C PALGTH - BEDZIE DLUGOSCIA LISTY PF DLA PROTOTYPU AKTUALNEGO IF (IPMEM(CLLREC+7) .EQ. 4) GOTO 1000 GOTO 900 C C...... PARAMETR AKTUALNY JEST PROCEDURA 300 PALGTH = 0 IF (IPMEM(CLLREC+7) .EQ. 5) GOTO 2000 C C------ NIEZGODNOSC RODZAJOW 900 CALL MERR(626, AID) GOTO 2000 C C C***** PARAMETRY SA FUNKCJAMI 1000 CONTINUE C--- ZBADANIE, CZY PF NIE JEST FUNKCJA DRUGIEGO RZEDU JESLI TAK C TO KONIECZNA JEST KONTROLA DYNAMICZNA DCONTR = .TRUE. IF (IPMEM(CLLREC+2) .EQ. 2) RETURN DCONTR = .FALSE. C--- ZBADANIE ZGODNOSCI TYPOW FUNKCJI FORMALNEJ I AKTUALNEJ CALL MFUNEQ (APROT, AID, AOB, PF, DCONTR) GOTO 3000 C C***** PARAMETRY SA PROCEDURAMI 2000 DCONTR = .TRUE. IF (IPMEM(CLLREC+2) .EQ. 2) RETURN DCONTR = .FALSE. C C C************************************************************************* C WSPOLNA DLA FUNKCJI I PROCEDUR KONTROLA ZGODNOSCI LIST C 3000 CONTINUE IF (APROT .GT. LPMSYS) GOTO 3010 C --UZYTY MODUL STANDARDOWY CALL MERR(635, AID) C TWORZONY JEST MALY REKORD ZAMIANY TYPOW (W CZESCI PRZEZNACZONEJ C NA PROTOTYPY UZYTKOWNIKA 3010 OLPMF = LPMF DCONTR = .FALSE. AFORM = .FALSE. IF (BTEST(IPMEM(APROT),11)) DCLASS = .TRUE. IF (IAND(ISHFT(IPMEM(APROT),-4),15) .NE. 0) AFORM = .TRUE. DCLASS = DCLASS .OR. AFORM C...... INICJALIZACJA PFEL = IPMEM(PF+3) C ELEMENT LISTY PF FUN/PROC FORMALNEJ PFLGTH = IPMEM(PF+4) IF (IPMEM(CLLREC+7) .EQ. 4) PFLGTH = PFLGTH-1 PAEL = IPMEM(APROT+3) C ELEMENT LISTY PF FUN/PROC AKTUALNEJ PALGTH = PALGTH + IPMEM(APROT+4) C C************* C------ SPRAWDZENIE CZY SA JESZCZE PARAMETRY W OBYDWU LISTACH IF ( (PALGTH .EQ. 0) .OR. (PFLGTH .EQ. 0) ) GOTO 6000 C --- SKOK DO POROWNANIA DLUGOSCI LIST C********************************* C***** POBRANIE I PRZETWARZANIE KOLEJNYCH PARAMETROW C 4000 PFPF = IPMEM(PFEL) PFPA = IPMEM(PAEL) C -PFPF - PARAMETR FORMALNY FUN/PROC FORMALNEJ C -PFPA - PARAMETR FORMALNY FUN/PROC AKTUALNEJ KINDPF = IPMEM(PFPF) KINDPF = IAND (ISHFT(KINDPF, -4), 15) + 1 KINDPA = IPMEM(PFPA) KINDPA = IAND(ISHFT(KINDPA, -4), 15) + 1 GOTO (5000, 4100, 4200, 4200, 5000, 4300, 4300, 5000, X 5000, 4300), KINDPF C C......PFPF JEST TYPEM FORMALNYM C PFPA TEZ MUSI BYC TYPEM FORMALNYM (LUB PARAMETREM C UNIWERSALNYM) C WSTAWIENIE PARY DO MALEGO REKORDU 4100 KINDPF = MGETM(2,0) IPMEM(KINDPF) = PFPF IPMEM(KINDPF+1) = PFPA IF (KINDPA .EQ. 2) GOTO 5000 IPMEM(KINDPF+1) = NRUNIV IF (KINDPA .EQ. 1) GOTO 5000 C SKOK DO SYGNALIZACJI BLEDU GOTO 4900 C C......PFPF JEST FUNKCJA LUB PROCEDURA C KONTROLA POLEGA JEDYNIE NA POROWNANIU RODZAJOW, GDYZ FUNKCJE I C PROCEDURY FORMALNE 2 RZEDU NIE NIOSA ZADNEJ INFORMACJI 4200 IF (KINDPA .EQ. KINDPF) GOTO 5000 GOTO 4900 C C......PFPF JEST PARAMETREM INPUT/OUTPUT/INOUT C WYWOLANIE PROCEDURY KONTROLUJACEJ ZGODNOSC TYPOW 4300 IF (KINDPA .LE. 5 ) GOTO 4900 CALL MPIO2 (DCONTR) IF (KINDPF .EQ. KINDPA) GOTO 5000 C C......NIEZGODNE RODZAJE PFPF I PFPA 4900 CALL MERR(627, AID) C*****PRZESUNIECIE LIST PARAMETROW 5000 PFEL = PFEL + 1 PAEL = PAEL + 1 PFLGTH = PFLGTH - 1 PALGTH = PALGTH - 1 IF ( (PFLGTH .NE. 0) .AND. (PALGTH .NE. 0) ) GOTO 4000 C*************************************** C C****************** C-------ZBADANIE ZGODNOSCI DLUGOSCI LIST PF C ZNISZCZENIE MALEGO REKORDU 6000 LPMF = OLPMF IF (PFLGTH .EQ. PALGTH) GOTO 6300 IF (PFLGTH .LT. PALGTH) GOTO 6100 C LISTA AKTUALNA JEST KROTSZA, POWINNA BYC USZKODZONA BY NIE BYLO C SYGNALIZACJI BLEDU C ZW - POLE S PROTOTYPU APROT IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6)) RETURN GOTO 6200 C TU: LISTA PF JEST KROTSZA, TA POWINNA BYC USZKODZONA BY NIE BYLO C SYGNALIZACJI BLEDU 6100 ZW = IPMEM(PF) ZW = IAND(ISHFT(ZW, -8), 7) + 1 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6)) RETURN C --- SYGNALIZACJA ROZNYCH DLUGOSCI LIST 6200 CALL MERR (630, AID) RETURN C ---LISTY ROWNYCH DLUGOSCI, SYGNALIZACJA BLEDOW GDY (TYLKO) JEDNA Z NICH C JEST USZKODZONA 6300 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6) ) GOTO 6100 C ---LISTA PARAMETROW MODULU AKTUALNEGO NIE JEST USZKODZONA, FORMALNEGO C ---TEZ NIE POWINNA BYC ZW = IPMEM(PF) ZW = IAND (ISHFT(ZW, -8), 7) + 1 IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6) ) GOTO 6200 C ---WSZYSTKO JEST W PORZADKU RETURN END *DECK MFUNEQ SUBROUTINE MFUNEQ (PA, AID, AOB, PF, DCONTR) C--------------PROCEDURA POMOCNICZA BADAJACA ZGODNOSC TYPOW FUNKCJI C AKTUALNEJ(PA) I FORMALNEJ (PF). C POZOSTALE PARAMETRY JAK W MPARPF. C W RAZIE POTRZEBY NADAJE WARTOSC ZMIENNEJ DCONTR. C SYGNALIZOWANE BLEDY: C 631 - NIEZGODNE TYPY FUNKCJI AKTUALNEJ I FORMALNEJ C 633 - TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY NIZ TYP C FUNKCJI FORMALNEJ C OPIS W DOKUMENTACJI: ?3.7.2 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 663 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL DCONTR C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C *CALL MTPC C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON COMMON /MTPC/ PRFXR, PRFXL C C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !! C C.....POBRANIE TYPU FUNKCJI AKTUALNEJ TRDIM = IPMEM(PA-4) TRBAS = IPMEM(PA-3) C.....POBRANIE TYPU FUNKCJI FORMALNEJ TLDIM = IPMEM(PF-4) TLBAS = IPMEM(PF-3) C.....MODYFIKACJA TYPU FUNKCJI FORMALNEJ W OPARCIU O REKORD KONTROLI OBJL = IPMEM(CLLREC+3) CALL MREPTP (TLDIM, TLBAS, OBJL) C.....POBRANIE SLOW ZEROWYCH TYPOW BAZOWYCH - POLA T AZW = IAND (IPMEM(TRBAS), 15) FZW = IAND (IPMEM(TLBAS), 15) C***************************** IF ( (TLDIM .GT. 0) .OR. (TRDIM .GT. 0) ) GOTO 2000 C******************* C TYPY NIETABLICOWE C C.....ROZPOZNANIE PRZYPADKU TYPOW PIERWOTNYCH IF (AZW .GE. 8) GOTO 100 IF (FZW .GE. 8) GOTO 200 GOTO 1000 C --SKOK, GDY ZADEN TYP NIE JEST PIERWOTNY C*****TYPY PIERWOTNE C.....TRBAS (FUNKCJA AKTUALNA) JEST PIERWOTNY 100 IF (TLBAS .EQ. NRUNIV) RETURN IF (TLBAS .EQ. TRBAS) RETURN GOTO 9100 C --SKOK GDY TYPY SA NIEZGODNE C.....TLBAS (FUNKCJA FORMALNA) JEST PIERWOTNY 200 IF (TRBAS .EQ. NRUNIV) RETURN C GOTO 9100 C C*****TYPY ZLOZONE NIETABLICOWE 1000 IF ( (TLBAS .EQ. NRUNIV) .OR. (TRBAS .EQ. NRUNIV) ) RETURN C.....OBYDWA TYPY SA KLASOWE, SYSTEMOWE LUB FORMALNE IF (FZW .EQ. 6) GOTO 1100 IF (AZW .EQ. 6) GOTO 9200 C --TEN SKOK GDY TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY - C SYGNALIZACJA BLEDU C.....OBYDWA TYPY SA KLASOWE LUB SYSTEMOWE C TYP FUNKCJI FORMALNEJ MUSI PREFIKSOWAC TYP FUNKCJI AKTUALNEJ IF (MPRFSQ (TLBAS, TRBAS) .NE. 0) GOTO 9000 C --SKOK GDY TAK NIE JEST C ...DODATKOWA KONTROLA DYNAMICZNA JEST POTRZEBNA, GDY WYWOLYWANY MODUL C JEST WIRTUALNY IF (IPMEM(CLLREC+2) .NE. 2) DCONTR = .TRUE. RETURN C C.....TYP TLBAS FUNKCJI FORMALNEJ JEST FORMALNY 1100 IF (AZW .EQ. 6) GOTO 1200 C ...TU TYP TLBAS JEST FORMALNY, TRBAS NIE - ZAWSZE POTRZEBNA KONTROLA C DYNAMICZNA DCONTR = .TRUE. RETURN C.....OBYDWA TYPY SA FORMALNE C - GDY WYWOLYWANY PROTOTYP JEST WIRTUALNY POTRZBNA KONTROLA DYNAMICZNA C - W PRZECIWNYM PRZYPADKU ORAZ GDY TYPY ZAWSZE POCHODZA Z TEGO SAMEGO C NIE MA KONTROLI DYNAMICZNEJ 1200 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 1250 PRFXR = AOB PRFXL = OBJL IF (MTPCON(Z) .EQ. 1) RETURN C ...POTRZEBNA KONTROLA DYNAMICZNA 1250 DCONTR = .TRUE. RETURN C C C******************** C TYPY ZLOZONE TABLICOWE (CO NAJMNIEJ JEDEN) 2000 IF (TLDIM-TRDIM) 2100, 2200, 2300 C C.....TLDIMTRDIM C POPRAWNE JEDYNIE, GDY OBA TYPY SA FORMALNE LUB UNIWERSALNE 2300 IF (TRBAS .EQ. NRUNIV) RETURN IF (AZW .NE. 6) GOTO 9100 IF (TLBAS .EQ. NRUNIV) RETURN IF (FZW .NE. 6) GOTO 9200 C ...OBYDWA SA FORMALNE DCONTR = .TRUE. PRFXR = AOB PRFXL = OBJL IF (MTPCON(Z) .NE. 1) RETURN IF (IPMEM(CLLREC+2) .NE. 0) RETURN GOTO 9100 C C*********************************** C SYGNALIZACJE BLEDOW C BADANIE OKRESLONOSCI TYPOW 9000 IF ( (AZW .EQ. 6) .AND. (FZW .NE. 6)) GOTO 9200 IF ( (TLBAS .NE. NRCOR) .AND. X ( (TRBAS .EQ. NRCOR) .OR. (TRBAS .EQ. NRPROC) ) ) X GOTO 9200 C C.....TYPY NIEZGODNE 9100 CALL MERR(631, AID) RETURN C.....TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY 9200 CALL MERR(633, AID) RETURN END *DECK MPIO2 SUBROUTINE MPIO2 (DCONTR) C--------------PROCEDURA POMOCNICZA KONTROLUJACA ZGODNOSC TYPOW C PARAMETROW FORMALNYCH 'INPUT'/'OUTPUT' DRUGIEGO C RZEDU - TO ZNACZY WYSTEPUJACYCH W LISTACH ODPO- C WIADAJACEJ MODULOWI FORMALNEMU (PF) ORAZ ODPO- C WIADAJACEJ MODULOWI AKTUALNEMU (APROT) C PFPF, PFPA - OPISY UZGADNIANYCH PARAMETROW C /EWENTUALNA NIEZGODNOSC RODZAJOW PARAMETROW SYGNA- C LIZOWANA JEST PRZEZ PROCEDURE MPARPF C SYGNALIZOWANE BLEDY: C 628 - NIEUZGODNIONE NAGLOWKI - TYPY PARAMETROW SA C NIEZGODNYCH RODZAJOW C 629 - NIEUZGODNIONE NAGLOWKI - TYPY PARAMETROW MAJA C ROZLACZNE SEKWENCJE PREFIKSOWE C 634 - NIEUZGODNIONE NAGLOWKI - TYP PARAMETRU W LISCIE C AKTUALNEJ JEST SLABIEJ OKRESLONY C C OPIS W DOKUMENTACJI: ?3.7.3.5 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 974 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL DCONTR,BTEST C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C *CALL MTPC C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON COMMON /MTPC/ PRFXR, PRFXL C C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !! C *CALL MPI2 C......BLOK KOMUNIKACJI PROCEDUR MPARPF ORAZ MPIO2 LOGICAL DCLASS, AFORM COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS, X AFORM C C !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14 !! C C.....POBRANIE TYPOW PARAMETROW PFPF I PFPA TRDIM = IPMEM(PFPA-4) TRBAS = IPMEM(PFPA-3) AZW = IAND (IPMEM(TRBAS), 15) TLDIM = IPMEM(PFPF-4) TLBAS = IPMEM(PFPF-3) OBJL = IPMEM(CLLREC+3) C.....ODDZIELENIE PRZYPADKU, GDY KTORYS Z TYPOW SAM JEST PARAMETREM PF C LUB APROT IF (IPMEM(TLBAS-1) .EQ. PF) GOTO 1000 C --SKOK GDY TYP W MODULE FORMALNYM JEST WLASNYM PARAMETREM TEGO MODULU IF (AZW .NE. 6) GOTO 2000 C --SKOK GDY TYP W MODULE AKTUALNYM NIE JEST FORMALNY IF (IPMEM(TRBAS-1) .EQ. APROT) GOTO 1000 IF (AFORM) GOTO 2000 IF (MPRFSQ(IPMEM(TRBAS-1), APROT) .EQ. 1) GOTO 1000 C --SKOK GDY TYP W MODULE AKTUALNYM JEST WLASNYM PARAMETREM MODULU GOTO 2000 C C***************************** C W CO NAJMNIEJ JEDNYM MODULE TYP JEST WLASNY W DRUGIM TEZ POWINIEN C BYC WLASNYM PARAMETREM I OBA POWINNY SOBIE ODPOWIADAC 1000 IF (TLBAS .NE. NRUNIV) GOTO 1100 IF (TLDIM .LE. TRDIM) RETURN GOTO 9100 1100 IF (TRBAS .NE. NRUNIV) GOTO 1200 IF (TLDIM .GE. TRDIM) RETURN GOTO 9100 C.....ZADEN TYP NIE JEST UNIWERSALNY, OBYDWA POWINNY BYC WLASNE I SOBIE C ODPOWIADAJACE 1200 IF (AZW .NE. 6) GOTO 9100 IF (IPMEM(TRBAS-1) .EQ. APROT) GOTO 1300 IF (AFORM) GOTO 9100 IF (MPRFSQ(IPMEM(TRBAS-1), APROT) .NE. 1) GOTO 9100 IF (IPMEM(TLBAS-1) .NE. PF) GOTO 9100 IF (TLDIM .NE. TRDIM) GOTO 9100 C.....OBYDWA TYPY SA WLASNE I MAJA ROWNE WYMIARY, C SPRAWDZENIE ODPOWIEDNIOSCI AZW = LPMF+1 1300 IF (IPMEM(AZW) .EQ. TLBAS) GOTO 1400 AZW = AZW+2 GOTO 1300 1400 TLBAS = IPMEM(AZW+1) IF (TLBAS .EQ. TRBAS) RETURN GOTO 9100 C C**************************************************** C*******TYPY NIE SA WLASNYMI PARAMETRAMI MODULOW C.....EWENTUALNA MODYFIKACJA TLBAS W OPARCIU O DUZY REKORD KONTROLI 2000 CALL MREPTP (TLDIM, TLBAS, OBJL) FZW = IAND(IPMEM(TLBAS), 15) IF ( (TLDIM .NE. 0) .OR. (TRDIM .NE. 0) ) GOTO 3000 C C********************* C TYPY NIETABLICOWE IF ( (TRBAS .EQ. NRUNIV) .OR. (TLBAS .EQ. NRUNIV) ) RETURN C.....ODDZIELENIE TYPOW PRYMITYWNYCH IF (FZW .GE. 8) GOTO 2200 IF (AZW .GE. 8) GOTO 2200 C.....ZADEN TYP NIE JEST PRYMITYWNY C.....ODDZILENIE TYPOW FORMALNYCH IF (FZW .EQ. 6) GOTO 2300 IF (AZW .EQ. 6) GOTO 9300 C --TEN SKOK GDY TYP W MODULE FORMALNYM JEST STATYCZNIE OKRESLONY, C NATOMIAST W MODULE AKTUALNYM JEST FORMALNY C **OBYDWA TYPY SA STATYCZNIE OKRESLONE - KLASOWE LUB SYSTEMOWE IF (TLBAS .EQ. TRBAS) GOTO 2100 IF (MPRFSQ (TLBAS, TRBAS) .EQ. -1) GOTO 9200 C --TYPY MAJA ROZLACZNE SEKWENCJE PREFIKSOWE - SKOK DO C SYGNALIZACJI BLEDU IF (DCLASS) DCONTR = .TRUE. IF (IPMEM(CLLREC+2) .NE. 0) DCONTR = .TRUE. RETURN C DODATKOWA KONTROLA JEST POTRZEBNA GDY MODUL AKTUALNY NIE JEST C RZECZYWISTY 2100 IF ((IPMEM(CLLREC+2) .NE. 0) .AND. DCLASS) DCONTR = .TRUE. C TYPY BYLY ROWNE - DODATKOWA KONTROLA DYNAMICZNA JEST C POTRZEBNA GDY JEDNOCZESNIE MODUL WYWOLYWANY BYL WIRTUALNY C ORAZ MODUL AKTUALNY NIE BYL RZECZYWISTY RETURN C C **CO NAJMNIEJ JEDEN TYP JEST PRYMITYWNY, DRUGI POWINIEN BYC MU ROWNY 2200 IF(TLBAS .EQ. TRBAS) RETURN GOTO 9100 C C **CO NAJMNIEJ TYP TLBAS JEST FORMALNY C TRBAS MOZE BYC WOWCZAS KLASOWY, SYSTEMOWY LUB FORMALNY 2300 IF (AZW .EQ. 6) GOTO 2400 C ...TYLKO TLBAS JEST FORMALNY - POTRZEBNA KONTROLA DYNAMICZNA 2350 DCONTR = .TRUE. RETURN C ...OBYDWA TYPY SA FORMALNE C KONTROLA DYNAMICZNA JEST ZAWSZE KONIECZNA, GDY WYWOLYWANY MODUL JEST C WIRTUALEM 2400 IF (IPMEM(CLLREC+2) .NE. 0) GOTO 2350 C ...KONTROLI DYNAMICZNEJ NIE MA, GDY TYP JEST TEN SAM I ZAWSZE C POCHODZI Z TEGO SAMEGO OBIEKTU PRFXR = AOB PRFXL = OBJL IF (MTPCON(Z) .EQ. 1) RETURN DCONTR = .TRUE. RETURN C C C**************************************** C TYPY TABLICOWE 3000 IF (TLDIM - TRDIM) 3100, 3200, 3300 C C.....TLDIMTRDIMCPOPRAWNE JEDYNIE, GDY OBYDWA TYPY SA FORMALNE LUB C UNIWERSALNE 3300 IF (TRBAS .EQ. NRUNIV) RETURN IF (AZW .NE. 6) GOTO 9100 IF (TLBAS .EQ. NRUNIV) RETURN IF (FZW .NE. 6) GOTO 9300 C ...OBYDWA TYPY SA FORMALNE DCONTR = .TRUE. PRFXR = AOB PRFXL = OBJL IF (MTPCON(Z) .NE. 1) RETURN IF (IPMEM(CLLREC+2) .NE. 0) RETURN IF (BTEST(IPMEM(APROT), 11)) RETURN GOTO 9100 C C*************************************** C SYGNALIZACJE BLEDOW 9100 CALL MERR(628, AID) RETURN C BADANIE OKRESLONOSCI TYPOW 9200 IF ( (TLBAS .NE. NRCOR) .AND. X ( (TRBAS .EQ. NRCOR) .OR. (TRBAS .EQ. NRPROC))) GOTO 9300 CALL MERR (629, AID) RETURN 9300 CALL MERR(634, AID) RETURN END *DECK MPARIO INTEGER FUNCTION MPARIO (ATDIM, ATBASE, ID, AOB) C-------------BADA ZGODNOSC TYPU PARAMETRU AKTUALNEGO (ATDIM, ATBASE) C Z TYPEM PARAMETRU FORMALNEGO (INPUT/OUTPUT). C ID - IDENTYFIKATOR UZYWANY W SYGNALIZACJI BLEDOW (NP. NAZWA C ZMIENNEJ, FUNKCJI) C AOB - OBIEKT W CIAGU SL, Z KTOREGO BRANY JEST PARAMETR C AKTUALNY, LUB 0 - GDY NIE JEST DOSTEPNY PRZEZ C DISPLAY C / WARTOSC FUNKCJI INFORMUJE O KONWERSJI LUB KONTROLI C DYNAMICZNEJ - TAK JAK W MSUBST. C ODPOWIEDNIOSC JEST NASTEPUJACA: C - PARAMETR INPUT C LEWA STRONA - PARAMETR FORMALNY C PRAWA STRONA - PARAMETR AKTUALNY C - PARAMETR OUTPUT C LEWA STRONA - PARAMETR AKTUALNY C PRAWA STRONA - PARAMETR FORMALNY C DODATKOWE UWAGI KONTEKSTOWE: C - W PRZYPADKU FUNKCJI I PROCEDUR WIRTUALNYCH - TYPY FOR- C MALNE SA ZAWSZE ZGODNE (ROZNICA W DZIALANIU MSUBST), C WYMAGANA JEST JEDNAK ZAWSZE KONTROLA DYNAMICZNA C - GDY FUN/PROC JEST WIRTULNA LUB FORMALNA - TYPY KLASOWE SA C ZGODNE JESLI SA WE WSPOLNEJ SEKWENCJI PREFIKSOWEJ- KONTRO- C LA DYNAMICZNA ROWNIEZ ZAWSZE POTRZEBNA C C SYGNALIZOWANE BLEDY C Z PROCEDURY MSUBST C 609 - NIEZGODNE TYPY C 610 - ROZLACZNE SEKWENCJE PREFIKSOWE C C OPIS W DOKUMENTACJI: ?3.6.2 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 519 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL FNFORM C FNFORM MA WARTOSC .TRUE. GDY PARAMETR FORMALNY NIE JEST C TYPU FORMALNEGO C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C C FNFORM = .TRUE. MPARIO = 0 C...... KONTROLA WYWOLANIA UNIWERSALNEGO IF (UNICLL) RETURN IF (IPMEM(CLLREC+7) .EQ. 0) RETURN C C------POBRANIE TYPU PARAMETRU FORMALNEGO PF = IPMEM(CLLREC+5) PF = IPMEM(PF) C ... PF OPIS PARAMETRU FORMALNEGO FDIM = IPMEM(PF-4) FBAS = IPMEM(PF-3) C ...FDIM, FBAS - NIEZMODYFIKOWANY TYP PARAMETRU FORM. C FOB = IPMEM(CLLREC+3) C PARAMETR FORMALNY "POCHODZI" Z TEGO SAMEGO OBIEKTU, CO OBIEKT C WYWOLYWANY C C------BADANIE RODZAJU OBIEKTU WYWOLYWANEGO C IF (IPMEM(CLLREC+2) .NE. 0) GOTO 1000 C C------ WYWOLYWANY ZWYKLY OBIEKT C...... MODYFIKACJA TYPU PARAMETRU FORMALNEGO IF ( IAND( IPMEM(FBAS), 15) .EQ. 6) FNFORM = .FALSE. CALL MREPTP(FDIM, FBAS, FOB) C......BADANIE RODZAJU PARAMETRU FORMALNEGO IF (IPMEM(CLLREC+7) .EQ. 6) GOTO 95 IF (IPMEM(CLLREC+7) .EQ. 2) GOTO 100 C --- KONTROLA PARAMETRU INPUT TLDIM = FDIM TLBAS = FBAS OBJL = FOB IDL = ID TRDIM = ATDIM TRBAS = ATBASE IDR = ID OBJR = AOB C MPARIO = MSUBST (Z) C Z - SLEPY PARAMETR IF (FNFORM) RETURN C....ZMIANA INFORMACJI O KONTROLI DYNAMICZNEJ GDY PARAMETR C FORMALNY JEST TYPU FORMALNEGO 90 IF ( (MPARIO .EQ. 3) .OR. (MPARIO .EQ. 5) ) MPARIO = X MPARIO + 1 RETURN C ---KONTROLA 'INOUT' - JAK OUTPUT PRZY PIERWSZYM WYWOLANIU, INPUT PRZY C DRUGIM 95 IPMEM(CLLREC+7) = -6 C --- KONTROLA PARAMETRU OUTPUT 100 TLDIM = ATDIM TLBAS = ATBASE IDL = ID OBJL = AOB TRBAS = FBAS TRDIM = FDIM IDR = ID OBJR = FOB C MPARIO = MSUBST(Z) IF (FNFORM) RETURN 110 IF ( (MPARIO .EQ. 3) .OR. (MPARIO .EQ. 4) ) MPARIO = X MPARIO + 2 RETURN C C------ OBIEKTY FORMALNE I WIRTUALNE C ---UWAGA: OBIEKTY WIRTUALNE NIGDY NIE SA DOSTEPNE PRZEZ DISPLAY 1000 IF (IPMEM(CLLREC+2) .EQ. 1) FOB = 0 C...... MODYFIKACJA TYPU PARAMETRU FORMALNEGO IF ( IAND( IPMEM(FBAS), 15) .EQ. 6) FNFORM = .FALSE. CALL MREPTP(FDIM, FBAS, FOB) C...... BADANIE RODZAJU PARAMETRU FORMALNEGO IF (IPMEM(CLLREC+7) .EQ. 2) GOTO 1100 C --- KONTROLA PARAMETRU INPUT TLDIM = FDIM TLBAS = FBAS IDL = ID OBJL = FOB TRDIM = ATDIM TRBAS = ATBASE IDR = ID OBJR = AOB C MPARIO = MSUBST (Z) IF (FNFORM) GOTO 1200 GOTO 90 C --- KONTROLA PARAMETRU OUTPUT 1100 TLDIM = ATDIM TLBAS = ATBASE IDL = ID OBJL = AOB TRDIM = FDIM TRBAS = FBAS IDR = ID OBJR = FOB C MPARIO = MSUBST (Z) C...... SPRAWDZENIE, CZY NIE SA TO TYPY KLASOWE- DLA NICH ZAWSZE C KONTROLA DYNAMICZNA IF ( .NOT. FNFORM) GOTO 110 1200 IF(MPARIO .NE. 0) RETURN C ... PF - OPIS PARAMETRU FORMALNEGO IF (IPMEM(PF-4).NE.0) RETURN PF = IPMEM(PF-3) C ..PF - OPIS TYPU PARAMETRU PF = IAND (IPMEM(PF), 15) IF (PF .GE. 8) RETURN MPARIO = 3 RETURN END *DECK MSUBST INTEGER FUNCTION MSUBST (X) C X - SLEPY PARAMETR C C-------------PROCEDURA BADA POPRAWNOSC INSTRUKCJI PODSTAWIENIA. C JEST ROWNIEZ WYWOLYWANA W PROCEDURZE KONTROLI C TYPOW PARAMETROW FORMALNYCH I AKTUALNYCH. C ZNACZENIE : C - TLDIM, TLBAS - TYP LEWEJ STRONY INSTRUKCJI PODSTAWIENIA, C OBJL - PROTOTYP, Z KTOREGO POCHODZI, LUB 0 - NIEDOSTEPNA C PRZEZ DISPLAY C IDL - IDENTYFIKATOR LEWEJ STRONY (DO SYGNALIZACJI C BLEDOW), C - ANALOGICZNIE DLA PRAWEJ STRONY - TRDIM, TRBAS, C OBJR . C // WARTOSC FUNKCJI OKRESLA RODZAJ KONWERSJI LUB KONTROLI C DYNAMICZNEJ : C 0 - OBIE STRONY SA TEGO SAMEGO TYPU, C 1 - INTEGER := REAL C 2 - REAL := INTEGER C DYNAMICZNA KONTROLA TYPOW C 3 - OBA TYPY OKRESLONE (STATYCZNIE) C 4 - TYP LEWEJ STRONY FORMALNY, PRAWEJ OKRESLONY C 5 - TYP LEWEJ STRONY OKRESLONY, PRAWEJ FORMALNY C 6 - TYPY OBYDWU STRON FORMALNE C ----SYGNALIZOWANE BLEDY C 609 - NIEZGODNE TYPY W PODSTAWIENIU C 610 - TYPY W PODSTAWIENIU MAJA ROZLACZNE SEKWENCJE PREFI- C KSOWE C 636 - NIEDOZWOLONE UZYCIE SEMAFORA C C OPIS W DOKUMENTACJI: ?2.7 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 617 C............................................................................. C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL MTPC C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON COMMON /MTPC/ PRFXR, PRFXL C C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !! C C INICJOWANA WARTOSC MSUBST - 3 ODPOWIADAJACA KONTROLI DYNAMICZNEJ MSUBST = 3 IF ( (TLDIM .EQ. 0) .AND. (TLBAS .EQ. NRUNIV) ) RETURN IF ( (TRDIM .EQ. 0) .AND. (TRBAS .EQ. NRUNIV) ) RETURN C POWROTY - GDY JEDEN Z TYPOW JEST UNIWERSALNY C TPL = IAND (IPMEM(TLBAS), 15) TPR = IAND(IPMEM(TRBAS), 15) C TPL I TPR - POLA T Z OPISU TYPOW TLBAS I TRBAS IF ( (TLDIM .NE. 0) .OR. (TRDIM .NE. 0) ) GOTO 1000 C SKOK DO BADANIA PODSTAWIEN DLA TYPOW TABLICOWYCH C------ TYPY NIETABLICOWE - ZADEN Z NICH NIE JEST JUZ UNIWERSALNY C GOTO (9000, 100, 100, 9500, 100, 200, 100, 300, 9100, 400, 500, X 400, 9000, 9000), TPL C C...... TPL JEST TYPEM KLASOWYM LUB SYSTEMOWYM 100 GOTO (9000, 110, 110, 9500, 110, 150, 110, 9000, 9100, 9000, X 9000, 9000, 9000, 130), TPR C ... TPR JEST ROWNIEZ TYPEM KLASOWYM LUB SYSTEMOWYM C SPRAWDZENIE PREFIKSOWANIA 110 IF ( MPRFSQ(TLBAS, TRBAS) ) 120, 130, 140 C SEKWENCJE PREFIKSOWE ROZLACZNE - PODSTAWIENIE MOZE BYC POPRAW- C NE JEDYNIE GDY JEDEN Z TYPOW JEST SYSTEMOWY 120 IF ( (TRBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRCOR) ) RETURN IF ( (TRBAS .EQ. NRPROC) .OR. (TLBAS .EQ. NRPROC) ) RETURN CALL MERR(610, IDL) RETURN C C TPL JEST PREFIKSEM TPR - KONTROLA DYNAMICZNA NIE JEST C POTRZEBNA, TPR MOZE BYC ROWNIEZ NONE 130 MSUBST = 0 RETURN C C TPR JEST PREFIKSEM TPL - KONTROLA DYNAMICZNA JEST POTRZEBNA C KONTEKSTOWO SYTUACJA JEST POPRAWNA 140 RETURN C ... TPR JEST FORMALNY 150 MSUBST = 5 RETURN C C C...... TPL JEST TYPEM FORMALNYM - TPR MUSI BYC TYPEM FORMALNYM, KLASO- C WYM, SYSTEMOWYM LUB NONE 200 MSUBST = 4 GOTO (9000, 210, 210, 9500, 210, 220, 210, 9000, 9100, 9000, X 9000, 9000, 9000, 210) , TPR C ...TPR - KLASOWY, SYSTEMOWY LUB NONE 210 RETURN C ... TPR - FORMALNY 220 MSUBST = 6 PRFXR = OBJR PRFXL = OBJL IF ( MTPCON(Z) .EQ. 1) MSUBST = 0 RETURN C C C...... TPL JEST ARYTMETYCZNY, TPR TEZ MUSI BYC ARYTMETYCZNY 300 IF ( (TRBAS .NE. NRINT) .AND. (TRBAS .NE. NRRE) ) GOTO 9000 MSUBST = 0 IF (TLBAS .EQ. TRBAS) RETURN C TU - TYPY ROZNE - POTRZEBNA KONWERSJA MSUBST = 2 IF (TLBAS .EQ. NRINT) MSUBST = 1 RETURN C C...... TPL - INNY PRYMITYWNY, TPR MUSI BYC MU ROWNE 400 MSUBST = 0 IF (TLBAS .EQ. TRBAS) RETURN GOTO 9000 C.......TPL - FILE, TPR MUSI BYC FILE LUB NONE 500 MSUBST = 0 IF ((TLBAS .EQ. TRBAS) .OR. (TRBAS .EQ. NRNONE)) RETURN GOTO 9000 C C C------ CO NAJMNIEJ JEDEN TYP JEST TABLICOWY C 1000 IF (TLDIM - TRDIM) 2000, 3000, 4000 C...... PRZYPADEK TLDIM < TRDIM C WOWCZAS PODSTAWIENIE JEST POPRAWNE JEDYNIE, GDY TLBAS JEST FOR- C MALNY LUB UNIWERSALNY. W PRZYPADKU, GDY OBA TYPY SA TYM SAMYM C TYPEM FORMALNYM - MUSZA POCHODZIC Z ROZNYCH OBIEKTOW. 2000 IF (TPL .EQ. 4) RETURN C POWROT DLA TYPU UNIWERSALNEGO IF (TPL .NE. 6) GOTO 9000 C SKOK DO SYGNALIZACJI BLEDU DLA TYPU NIEFORMALNEGO MSUBST = 4 IF (TPR .EQ. 6) MSUBST = 6 GOTO 8000 C C......PRZYPADEK TLDIM = TRDIM C POPRAWNE, GDY C - OBA TYPY BAZOWE SA ROWNE C - CO NAJMNIEJ JEDEN JEST FORMALNY LUB UNIWERSALNY 3000 IF ( (TPL .EQ. 4) .OR. (TPR .EQ. 4) ) RETURN C POWROT - GDY JEDEN Z TYPOW JEST UNIWERSALNY C IF ( (TPL .EQ. 6) .AND. (TPR .EQ. 6) ) GOTO 3300 IF (TPL .EQ. 6) GOTO 3100 IF (TPR .EQ. 6) GOTO 3200 C SKOKI ROZDZIELAJACE PRZYPADKI TYPOW FORMALNYCH C ... PRZYPADEK, GDY TYPY NIE SA FORMALNE MSUBST = 0 IF (TLBAS .EQ. TRBAS) RETURN C TU - NIEROWNE TYPY NIEFORMALNE - SKOK DO SYGNALIZACJI BLEDOW GOTO 9000 C C ... TLBAS JEST FORMALNY, TRBAS NIE 3100 MSUBST = 4 RETURN C ... TRBAS JEST FORMALNY, TLBAS NIE 3200 MSUBST = 5 RETURN C ... TLBAS I TRBAS SA FORMALNE, SPRAWDZENIE,CZY SA ROWNE I LOKALNE C (WTEDY NIE MA KONTROLI DYNAMICZNEJ) 3300 MSUBST = 6 PRFXR = OBJR PRFXL = OBJL IF ( MTPCON(Z) .EQ. 1) MSUBST = 0 RETURN C C...... PRZYPADEK TLDIM > TRDIM C POPRAWNE,GDY: C - TYP NONE Z PRAWEJ STRONY C - TRBAS JEST FORMALNY LUB UNIWERSALNY, W PRZYPADKU GDY OBA C TYPY SA TYM SAMYM TYPEM FORMALNYM CO NAJMNIEJ JEDEN Z NICH C MUSI BYC NIELOKALNY 4000 MSUBST = 0 IF (TPR .EQ. 4) RETURN C POWROT DLA TYPU UNIWERSALNEGO Z PRAWEJ STRONY IF ( (TPR .EQ. 14) .AND. (TRDIM .EQ. 0) ) RETURN C POWROT DLA STALEJ NONE IF (TPR .NE. 6) GOTO 9000 C SKOK DO SYGNALIZACJI BLEDU DLA TYPU NIEFORMALNEGO MSUBST = 5 IF (TPL .EQ. 6) MSUBST = 6 C GOTO 8000 - PRZEJSCIE DO BADANIA TYPOW TABLICOWYCH C C C------ BADANIE ZGODNOSCI FORMALNYCH TYPOW TABLICOWYCH C 8000 PRFXR = OBJR PRFXL = OBJL IF ( MTPCON(Z) .EQ. 1) GOTO 9000 RETURN C C C C------SYGNALZACJA BLEDOW 9000 IF (TPR .EQ. 9) GOTO 9100 CALL MERR(609, IDL) 9500 RETURN 9100 IF (TPL .EQ. 9) CALL MERR(636, IDL) IF (TPR .EQ. 9) CALL MERR(636, IDR) RETURN END *DECK MEQUAL SUBROUTINE MEQUAL (CASE) C-------------PROCEDURA BADA ZGODNOSC ARGUMENTOW RELACJI = I =/= . C TYPY PRAWEGO I LEWEGO ARGUMENTU PRZEKAZANE SA PRZEZ C BLOK /SEMANT/ , SA TO : C TLDIM, TLBAS - DLA LEWEGO ARGUMENTU C TRDIM, TRBAS - DLA PRAWEGO ARGUMENTU. C ZMIENNE OBJL, OBJR - NUMERY PROTOTYPOW OBIEKTOW, KTORYCH C ATRYBUTAMI SA ODPOWIEDNIO LEWY I PRAWY ARGUMENT OPERACJI. C SA ONE ROWNE ZERU, GDY ARGUMENTY NIE SA DOSTEPNE PRZEZ C DISPLAY. C ZMIENNE IDL ORAZ IDR SLUZA DO IDENTYFIKACJI BLEDOW - SA C TO IDENTYFIKATORY LEWEGO I PRAWEGO ARGUMENTU. C // WARTOSCI PARAMETRU CASE PRZY WYJSCIU OKRESLAJA : C 1 - OBA ARGUMENTY SA INTEGER C 2 - CO NAJMNIEJ JEDEN ARGUMENT JEST TYPU REAL, DRUGI C MUSI BYC ARYTMETYCZNY. ZMIENNE CONVL I CONVR OKRE- C SLAJA EWENTUALNA KONWERSJE C 3 - OBA ARGUMENTY SA BOOLOWSKIE C 4 - OBA ARGUMENTY SA TYPU CHAR C 5 - OBA ARGUMENTY SA TYPU REFERENCYJNEGO (ROWNIEZ C TABLICOWEGO, TEGO SAMEGO FORMALNEGO I PLIKOWEGO) C - ZGODNE STATYCZNIE C 6 - J.W. - CO NAJMNIEJ JEDEN JEST FORMALNY I WYMAGANA C DYNAMICZNA KONTROLA ZGODNOSCI C ----SYGNALIZOWANE BLEDY: C 606 - RODZAJE TYPOW WYSTEPUJACYCH W POROWNANIU SA NIEZGO- C DNE C 607 - W POROWNANIU BIORA UDZIAL TYPY KLASOWE Z ROZLACZNA C SEKWENCJA PREFIKSOWA C 608 - POROWNYWANY JEST TYP STRING C 636 - NIEDOZWOLONE UZYCIE SEMAFORA C C OPIS W DOKUMENTACJI: ?2.6 C WERSJA Z DNIA: 13.05.83 (FRIDAY) C DLUGOSC KODU: 664 C............................................................................. C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL MTPC C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON COMMON /MTPC/ PRFXR, PRFXL C C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !! C CONVL = 0 CONVR = 0 TPL = IAND( IPMEM(TLBAS), 15) TPR = IAND (IPMEM(TRBAS), 15) C TPL,TPR - POLA T TYPOW BAZOWYCH LEWEJ I PRAWEJ STRONY IF ((TLDIM .NE. 0) .OR. (TRDIM .NE. 0)) GOTO 1000 C SKOK DO POROWNYWANIA TYPOW TABLICOWYCH C GOTO (9000, 100, 100, 200, 100, 300, 100, 400, 9100, 500, X 800, 700, 9000, 300), TPL C C-----TPL JEST TYPEM KLASOWYM LUB SYSTEMOWYM 100 CASE = 5 GOTO (9000, 110, 110, 120, 110, 130, 110, 9000, 9100, 9000, X 9000, 9000, 9000, 120), TPR C....... TPR JEST TEZ TYPEM KLASOWYM LUB SYSTEMOWYM 110 IF ((TRBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRCOR)) RETURN IF ((TRBAS .EQ. NRPROC) .OR. (TLBAS .EQ. NRPROC)) RETURN C PRZYPADEK, GDY OBA TYPY SA TYPAMI KLASOWYMI - WOWCZAS ICH C SEKWENCJE PREFIKSOWE NIE MOGA BYC ROZLACZNE IF ( MPRFSQ(TRBAS,TLBAS) .GE. 0) RETURN C ROZLACZNE SEKWENCJE PREFIKSOWE PONIZEJ CALL MERR(607, IDL) RETURN C C....... TPR JEST TYPEM UNIWERSALNYM LUB TYPEM NONE 120 RETURN C C....... TPR JEST TYPEM FORMALNYM 130 CASE = 6 RETURN C C C----- TPL JEST TYPEM UNIWERSALNYM, WTEDY POROWNANIE JEST ZAWSZE C POPRAWNE - O ILE TPR NIE JEST TYPEM TEKSTOWYM 200 CASE = 5 IF (TRBAS .EQ. NRTEXT) GOTO 700 RETURN C C----- TPL JEST TYPEM FORMALNYM LUB TYPEM NONE - BY ZACHODZILA ZGODNOSC C TO TPR MUSI BYC TYPEM FORMALNYM, KLASOWYM, SYSTEMOWYM, UNIWER- C SALNYM LUB NONE 300 CASE = 6 IF ( (TPL .EQ. 14) .OR. (TPR .EQ. 14) ) CASE = 5 C-----JESLI POROWNANIE NONE Z FILE IF ((TPL .EQ. 14) .AND. (TPR .EQ. 11)) RETURN IF (TPR .GE. 13) RETURN IF (TPR .GE. 8) GOTO 9000 IF (TPR .EQ. 6) GOTO 8000 IF (TPR .GE. 1) RETURN GOTO 9000 C C----- TPL JEST TYPEM ARYTMETYCZNYM, WTEDY TPR TEZ MUSI BYC ARYTMETYCZNE C (LUB UNIWERSALNE) 400 IF ((TRBAS .NE. NRINT) .AND. X (TRBAS .NE. NRRE) .AND. X (TRBAS .NE. NRUNIV)) GOTO 9000 CASE = 2 cdsw IF ((TPR .EQ.TPL) .AND. (TRBAS .EQ.NRINT)) CASE = 1 IF ((trbas .EQ. tlbas) .AND. (TRBAS .EQ. NRINT) ) CASE = 1 CONVL = 0 CONVR = 0 IF (CASE .EQ. 1) RETURN IF (TLBAS .EQ. NRINT) CONVL = 1 IF (TRBAS .EQ. NRINT) CONVR = 1 RETURN C C-----TPL JEST TYPEM BOOLEAN LUB CHARACTER, WTEDY TPR MUSI BYC ROWNIEZ C BOOLEAN LUB CHARACTER (LUB UNIWERSALNY) 500 IF ((TRBAS .EQ. NRCHR) .OR. (TLBAS .EQ. NRCHR)) GOTO 600 CASE = 3 IF ((TRBAS .EQ. NRBOOL) .OR. (TRBAS .EQ. NRUNIV)) RETURN GOTO 9000 C C-----TPL JEST TYPEM CHAR, WTEDY TPR MUSI BYC BADZ CHAR BADZ UNIWER- C SALNY 600 CASE = 4 IF ((TRBAS .EQ. NRCHR) .OR. (TRBAS .EQ. NRUNIV)) RETURN GOTO 9000 C C-----TPL JEST TYPEM TEKSTOWYM, NIEZALEZNIE OD TPR JEST TO BLAD 700 CASE = 5 CALL MERR(608, IDL) IF (TRBAS .EQ. NRTEXT) CALL MERR(608, IDR) RETURN C C-----TPL - FILE. TPR MUSI BYC FILE LUB UNIWERSALNY LUB NONE 800 CASE = 5 IF ((TPR .EQ. 11) .OR. (TRBAS .EQ. NRUNIV) X .OR. (TRBAS .EQ. NRNONE)) RETURN GOTO 9000 C C C----- POROWNYWANIE TYPOW TABLICOWYCH 1000 CASE = 5 IF (TLDIM-TRDIM) 2000, 3000, 4000 C...... PRZYPADEK TLDIM < TRDIM C WOWCZAS POPRAWNE JEDYNIE, GDY TLBAS JEST FORMALNY, UNIWERSALNY C LUB NONE C W PRZYPADKU, GDY OBA TYPY SA TYM SAMYM TYPEM FORMALNYM MUSZA C POCHODZIC Z ROZNYCH OBIEKTOW 2000 IF ((TPL .EQ. 4) .OR. (TPL .EQ. 14)) RETURN IF (TPL .NE. 6) GOTO 9000 C KONTROLA, GDY CO NAJMNIEJ JEDENz JEST FORMALNY GOTO 8500 C C...... PRZYPADEK TLDIM = TRDIM C POPRAWNE, GDY : C - OBA TYPY BAZOWE SA ROWNE C LUB - CO NAJMNIEJ JEDEN Z NICH JEST FORMALNY LUB UNIWERSALNY 3000 IF ( (TPR .EQ. 4) .OR. (TPL .EQ. 4) ) RETURN IF ( (TPR .EQ. 6) .OR. (TPL .EQ. 6) ) GOTO 8000 C SKOK, GDY CO NAJMNIEJ JEDEN TYP BAZOWY JEST FORMALNY IF (TRBAS .EQ. TLBAS) RETURN GOTO 9000 C C...... PRZYPADEK TLDIM > TRDIM C POPRAWNE GDY TRBAS JEST FORMALNY, UNIWERSALNY LUB NONE - C DALSZE UWAGI JAK PRZY TLDIM < TRDIM 4000 IF ((TPR .EQ. 4) .OR. (TPR .EQ. 14)) RETURN IF (TPR .NE. 6) GOTO 9000 GOTO 8500 C C C------ USTALENIE RODZAJU ZGODNOSCI TYPOW REFERENCYJNYCH, GDY CO C NAJMNIEJ JEDEN Z NICH JEST TYPEM FORMALNYM C 8000 CASE = 6 PRFXR = OBJR PRFXL = OBJL IF ( MTPCON(Z) ) 8200, 8200, 8100 C MTPCON PRZYJMUJE NASTEPUJACE WARTOSCI C -1 - TYP TEN SAM Z ROZNYCH OBIEKTOW C 0 - TYPY ROZNE C +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU C 8100 CASE = 5 8200 RETURN C C...... UZTALENIE ZGODNOSCI TYPOW TABLICOWYCH - JEDEN Z NICH C JEST FORMALNY C 8500 CASE = 6 PRFXR = OBJR PRFXL = OBJL IF ( MTPCON(Z) .NE. 1) RETURN C WPP - SYGNALIZACJA BLEDOW - NIE MA PODSTAWIENIA UNIFIKU- C JACEGO C C C C------ SYGNALIZOWANIE BLEDOW 9000 CASE = 5 IF (TPR .EQ. 9) GOTO 9100 IF ((TRDIM .EQ. 0) .AND. (TRBAS .EQ. NRTEXT)) CALL MERR(608, X IDR) CALL MERR(606, IDL) RETURN C --- SYGNALIZACJA BLEDOW - NIEDOZWOLONE UZYCIE SEMAFORA 9100 CASE = 5 IF (TPL .EQ. 9) CALL MERR(636, IDL) IF (TPR .EQ. 9) CALL MERR(636, IDR) RETURN END *DECK MPKIND INTEGER FUNCTION MPKIND (ATTRAD) C-------------FUNKCJA OKRESLAJACA RODZAJ KOLEJNEGO PARAMETRU C FORMALNEGO C / WARTOSCIA PARAMETRU ATTRAD JEST IDENTYFIKATOR C (INDEKS W IPMEM) OPISU TEGO PARAMETRU C / ZMIENNA NRPAR (Z BLOKU /SEMANT/) MA WARTOSC ROWNA C NUMEROWI PARAMETRU WEWNATRZ LISTY PARAMETROW FORMAL- C NYCH (0,1,2,...) C / WARTOSC FUNKCJI OKRESLA RODZAJ PARAMETRU FORMALNEGO C 0 - UNIWERSALNY C 1 - INPUT C 2 - OUTPUT C 3 - TYP C 4 - FUNKCJA C 5 - PROCEDURA C // FUNKCJA KORZYSTA Z PROCEDURY MNOPF C SYGNALIZOWANY BLAD C 622 (Z MNOPF) - ZA KROTKA LISTA PF C C OPIS W DOKUMENTACJI: ?3.4.3.2 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 141 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL MNOPF C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C C MPKIND = 0 ATTRAD = NRUNIV IF (MNOPF(0)) RETURN C C***************************************************************************** C PARAMETR ZOSTAL POBRANY ATTRAD = IPMEM(CLLREC+5) ATTRAD = IPMEM(ATTRAD) NRPAR = IPMEM(CLLREC+4) C------ ROZPOZNANIE BIEZACEGO PARAMETRU C ZW - SLOWO ZEROWE OPISU PARAMETRU ZW = IPMEM(ATTRAD) ZW = IAND (ISHFT(ZW, -4), 15) +1 GOTO (1000, 100, 200, 300, 1000, 400, 500, 1000, X 1000, 600), ZW C C...... TYP FORMALNY 100 MPKIND = 3 GOTO 1000 C C...... FUNKCJA 200 MPKIND = 4 GOTO 1000 C C...... PROCEDURA 300 MPKIND = 5 GOTO 1000 C C...... INPUT 400 MPKIND = 1 GOTO 1000 C C...... OUTPUT 500 MPKIND = 2 GOTO 1000 C C.....INOUT 600 MPKIND = 6 C C***************************************************************************** C------ ZAKONCZENIE 1000 IPMEM(CLLREC+7) = MPKIND RETURN END *DECK MPARTP SUBROUTINE MPARTP (ATDIM, ATBASE, OB, IDBASE) C-------------PRZETWARZANIE PARAMETRU AKTUALNEGO BEDACEGO TYPEM C DO REKORDU KONTROLI WPISUJE SIE INFORMACJE O TYPIE C AKTUALNYM ZASTEPUJACYM TYP-PARAMETR FORMALNY. C ATDIM, ATBASE - LICZBA ARRAY OF I TYP BAZOWY AKTUALNY C OB - NUMER OBIEKTU Z CIAGU SL, Z KTOREGO JEST POBIERANY C LUB ZERO, GDY NIE JEST DOSTEPNY PRZEZ DISPLAY C IDBASE - NAZWA ZE SCANNERA TYPU BAZOWEGO (DO SYGNALIZACJI C BLEDOW) C C SYGNALIZOWANE BLEDY C 624 - TYP AKTUALNY NIE JEST REFERENCYJNY C 625 - ATBASE NIE JEST TYPEM C 637 - 'SEMAPHORE' NIE MOZE BYC TYPEM AKTUALNYM C C /PROCEDURA TWORZY NOWA CZWORKE TYPOW DO MODYFIKACJI C C OPIS W DOKUMENTACJI: ?3.5 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 207 C............................................................................. C IMPLICIT INTEGER (A-Z) C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C C C...... POWROTY DLA WYWOLANIA NIEKONTROLOWANEGO IF (UNICLL) RETURN IF (IPMEM(CLLREC+7) .EQ. 0) RETURN C C------UTWORZENIE NOWEJ CZWORKI W REKORDZIE KONTROLI INSYS = .TRUE. K = MGETM(4, 0) INSYS = .FALSE. C...... ZAPIS NUMERU TYPU FORMALNEGO PF = IPMEM(CLLREC+5) IPMEM(K) = IPMEM(PF) C...... ZAPIS INFORMACJI O TYPIE AKTUALNYM IPMEM(K+1) = ATDIM IPMEM(K+2) = ATBASE IPMEM(K+3) = OB C...... KONTROLA, CZY TYP AKTUALNY JEST DOPUSZCZALNY 100 PF = IPMEM(ATBASE) PF = IAND(PF, 15) C PF - POLE T Z OPISU TYPU ATBASE IF (PF .EQ. 1) GOTO 200 C ... ATBASE NIE JEST TYPEM IF (PF .EQ. 9) GOTO 210 IF (ATDIM .NE. 0) RETURN C ---TYPY TABLICOWE SA REFERENCYJNE IF (PF .LE. 7) RETURN C ---POWROT DLA POZOSTALYCH TYPOW REFERENCYJNYCH C C------SYGNALIZACJA BLEDU - TYP AKTUALNY NIE JEST REFERENCYJNY CALL MERR(624, IDBASE) IPMEM(K+2) = NRUNIV RETURN C------SYGNALIZACJA BLEDU- PARAMETR ATBASE NIE JEST TYPEM 200 CALL MERR(625, IDBASE) 205 IPMEM(K+1) = 0 IPMEM(K+2) = NRUNIV RETURN C-----PARAMETREM JEST TYP 'SEMAPHORE' - BLAD 210 CALL MERR(637, 0) GOTO 205 END *DECK MREPTP SUBROUTINE MREPTP (TDIM, TBAS, OB) C-------------PROCEDURA MODYFIKUJE TYP (TDIM, TBAS) PRZEZ C ZASTAPIENIE EWENTUALNEGO TYPU FORMALNEGO TYPEM AKTUALNYM C JEMU ODPOWIADAJACYM. C TDIM, TBAS - OKRESLA ROWNIEZ TYP PO MODYFIKACJI C DANE DOTYCZACE DOSTEPNOSCI : OB C /PROCEDURA UZYWANA JEDYNIE, GDY WYWOLANIE JEST KONTROLO- C WANE C C OPIS W DOKUMENTACJI: ?3.6.1 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 112 C............................................................................. C IMPLICIT INTEGER (A-Z) C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C C K - INDEKS PIERWSZEJ PIATKI TYPOW ZASTEPOWANYCH C L - INDEKS OSTATNIEJ PIATKI TYPOW ZASTEPOWANYCH L = LPML - 4 K = CLLREC + 8 C...... SPRAWDZENIE, CZY LISTA TYPOW NIE JEST PUSTA IF (K .GT. L) RETURN C------ SZUKANIE W NIEPUSTEJ LISCIE C 10 IF (IPMEM(K) .EQ. TBAS) GOTO 20 C ---SKOK, GDY TYP JEST ODNALEZIONY IF (K .EQ. L) RETURN C ---POWROT, GDY TYP NIE WYSTEPUJE W LISCIE K = K+4 GOTO 10 C C------ TYP ODNALEZIONY 20 TDIM = TDIM + IPMEM(K+1) TBAS = IPMEM(K+2) OB = IPMEM(K+3) RETURN END *DECK MCALLO SUBROUTINE MCALLO (NRPROT, IDPROT, OB, KIND) C-------------PROCEDURA OTWIERA REKORD KONTROLI STATYCZNEJ NOWEGO C WYWOLANIA (WKLADAJAC NA STOS), INICJUJE TEN REKORD C PARAMETRY WEJSCIOWE C NRPROT - NUMER WYWOLYWANEGO PROTOTYPU C IDPROT - NAZWA ZE SCANNERA WYWOLYWANEGO PROTOTYPU C OB - NUMER OBIEKTU Z CIAGU SL, Z KTOREGO WYWOLYWANY C PROTOTYP POCHODZI C PARAMETR WYJSCIOWY C KIND - WARTOSCI C = 0 ZWYKLY PROTOTYP C = 1 WIRTUALNY C = 2 FORMALNY C C OPIS W DOKUMENTACJI: ?3.4.2 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 262 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL BTEST C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! *CALL MID COMMON /MID/ PSTART, CHECKS C C------ UTWORZENIE REKORDU DLA WYWOLANIA UNIWERSALNEGO KIND = 0 UNICLL = .TRUE. CHECKS = CHECKS+1 INSYS = .TRUE. RECORD = MGETM(2, 0) IPMEM(RECORD) = CLLREC CLLREC = RECORD+1 INSYS = .FALSE. IF (NRPROT .EQ. NRUNIV) RETURN C------ UTWORZENIE REKORDU DLA WYWOLANIA KONTROLOWANEGO INSYS = .TRUE. UNICLL = .FALSE. RECORD = MGETM(7, 0) INSYS = .FALSE. C...... INICJALIZACJA SLOW REKORDU C RECORD - ZEROWE SLOWO WYWOLYWANEGO REKORDU RECORD = IPMEM(NRPROT) IPMEM(CLLREC) = NRPROT IPMEM(CLLREC+1) = IDPROT C...... ZBADANIE, CZY TO JEST PROTOTYP WIRTUALNY KIND = 1 IF (BTEST(RECORD, 11) ) GOTO 100 C...... ZBADANIE, CZY TO PROTOTYP FORMALNY C (PRZY POMOCY POLA ZP) KIND = 0 ZP = IAND(ISHFT(RECORD, -4), 15) IF ( ZP .NE. 0) KIND = 2 C --- ZBADANIE, CZY TO NIE JEST SYGNAL IF (ZP .EQ. 11) KIND = 0 100 IPMEM(CLLREC+2) = KIND C...... INICJALIZACJA DALSZYCH SLOW IPMEM(CLLREC+3) = OB C...... WYPELNIENIE INFORMACJI O LISCIE PARAMETROW IPMEM(CLLREC+4) = -1 IPMEM(CLLREC+5) = IPMEM(NRPROT+3) - 1 IPMEM(CLLREC+6) = IPMEM(CLLREC+5) + IPMEM(NRPROT+4) C...... SKROCENIE LISTY PF DLA FUNKCJI - OSTATNI ELEMENT JEST C ZMIENNA RESULT RECORD = IAND( ISHFT(RECORD, -8), 7) IF (RECORD .EQ. 2) IPMEM(CLLREC+6) = X IPMEM(CLLREC+6)-1 RETURN END *DECK MCALLC SUBROUTINE MCALLC C-------------ZAKONCZENIE KONTROLI WYWOLANIA, ZBADANIE C ZGODNOSCI LICZBY PARAMETROW FORMALNYCH I PARAME- C TROW AKTUALNYCH C ZDJECIE REKORDU KONTROLI ZE STOSU C SYGNALIZOWANY BLAD C 623 - LISTA PF JEST DLUZSZA OD LISTY PARAMETROW C AKTUALNYCH C C OPIS W DOKUMENTACJI: ?3.4.4.2 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 89 C............................................................................. C C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! *CALL MID COMMON /MID/ PSTART, CHECKS C C CHECKS = CHECKS - 1 IF (UNICLL) GOTO 1000 C C****** KONTROLA DLUGOSCI LIST PF I PA IF (IPMEM(CLLREC+5) .EQ. IPMEM(CLLREC+6) ) GOTO 1000 C --- SYGNALIZACJA BLEDU CALL MERR(623, IPMEM(CLLREC+1) ) C C****** ZDJECIE REKORDU ZE SZCZYTU STOSU 1000 LPML = CLLREC-1 CLLREC = IPMEM(CLLREC-1) UNICLL = .FALSE. IF (IPMEM(CLLREC) .EQ. 0) UNICLL = .TRUE. RETURN END *DECK MNOPF LOGICAL FUNCTION MNOPF (X) C-------------FUNKCJA SLUZY DO POBRANIA NOWEGO PARAMETRU C KONTROLUJE, CZY JEST TO MOZLIWE C //PRZYJMUJE WARTOSC .TRUE. GDY LISTA PF JEST PUSTA, C SYGNALIZUJE WOWCZAS (O ILE WYWOLYWANY PROTOTYP NIE C MIAL USZKODZONEJ LISTY) BLAD C ZMIENIA WYWOLANIE NA NIEKONTROLOWANE C //GDY LISTA PF NIE JEST PUSTA C AKTUALIZUJE SLOWA 5 I 6 W REKORDZIE KONTROLI C //// X - PARAMETR NIEISTOTNY C SYGNALIZOWANY BLAD C 622 - LISTA PF KROTSZA OD LISTY PARAMETROW AKTUALNYCH C C OPIS W DOKUMENTACJI: ?3.4.3.1 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 168 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL BTEST C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C MNOPF = .TRUE. IF (UNICLL) RETURN MNOPF = .FALSE. C C****** MODYFIKACJA NUMEROW PARAMETRU FORMALNEGO I ELEMENTU LISTY IPMEM(CLLREC+4) = IPMEM(CLLREC+4) + 1 IPMEM(CLLREC+5) = IPMEM(CLLREC+5) + 1 C------ KONTROLA DLUGOSCI LISTY PF I PA IF (IPMEM(CLLREC+5) .LE. IPMEM(CLLREC+6) ) RETURN C C****** PRZYPADEK, GDY NIE MA JUZ POTRZEBNEGO PF C -SYGNALIZACJA BLEDU, GDY WYWOLYWANY PROTOTYP NIE JEST C USZKODZONY C -SKROCENIE REKORDU KONTROLI STATYCZNEJ DO WYWOLANIA UNIWERSAL- C NEGO C MNOPF = .TRUE. C C ZW - SLOWO ZEROWE PROTOTYPU ZW = IPMEM(CLLREC) ZW = IPMEM(ZW) C ---SKOK DLA USZKODZONEJ LISTY IF (BTEST(ZW, 13)) GOTO 100 C C------ SYGNALIZACJA BLEDU CALL MERR(622, IPMEM(CLLREC+1)) C------ SKROCENIE REKORDU KONTROLI 100 CALL MUNICL RETURN END *DECK MUNICL SUBROUTINE MUNICL C-------------PROCEDURA ZASTEPUJACA WYWOLANIE KONTROLOWANE C WYWOLANIEM OBIEKTU UNIWERSALNEGO C / JEST WYKONYWANA, GDY W WYWOLANIU BYLY BLEDY UNIE- C MOZLIWIAJACE DALSZA POPRAWNA ANALIZE C C OPIS W DOKUMENTACJI: ?3.4.4.1 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 31 C............................................................................. C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL STCON C...... LOGICAL UNICLL COMMON /MCALLS/ CLLREC, UNICLL C C !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14 !! C LPML = CLLREC+1 UNICLL = .TRUE. IPMEM(CLLREC) = 0 RETURN END *DECK MTPCON INTEGER FUNCTION MTPCON (X) C X - "SLEPY" PARAMETR C-------------POMOCNICZA FUNKCJA DO KONTROLI TYPOW FORMALNYCH. C OKRESLA, CZY TYPY TRBAS I TLBAS ATRYBUTOW POCHODZACYCH C Z OBIEKTOW/WARSTW PRFXR I PRFXL (DOSTEPNYCH PRZEZ DISPLAY C ODPOWIEDNIO TE WARTOSCI SA WIEKSZE OD ZERA) SA TYM SAMYM C TYPEM FORMALNYM. C /WARTOSCI : C -1 - TYP TEN SAM, Z ROZNYCH OBIEKTOW C 0 - TYPY ROZNE C +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU C C OPIS W DOKUMENTACJI: ?2.2.3 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 362 C............................................................................. C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL MTPC C......BLOK KOMUNIKACJI Z PROCEDURA MTPCON COMMON /MTPC/ PRFXR, PRFXL C C !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14 !! C *CALL MOB C......KOMUNIKACJA Z PROCEDURA MOBJFD LOGICAL WCL1,WCL2 COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2 C C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !! C C******************************************* C WARUNKI DOSTATECZNE NA TO BY TYP POCHODZIL Z TEGO C SAMEGO OBIEKTU: C - OBYDWA ATRYBUTY SA DOSTEPNE PRZEZ DISPLAY C ORAZ JEDEN Z PONIZSZYCH C (A) POCHODZA Z TEJ SAMEJ WARSTWY (TEN SAM NUMER C W DISPLAY-U) C (B) OBIEKTY W CIAGU SL DLA PROTOTYPU AKTUALNEGO, C Z KTORYCH POCHODZA TYPY, SA ROWNE DLA OBYDWU C ATRYBUTOW ORAZ W LANCUCHU SL OD PROTOTYPU C AKTUALNEGO DO TEGO OBIEKTU NIE WYSTEPUJA ZADNE C KLASY (NATOMIAST SAME OBIEKTY MOGA BYC KLASAMI) C (C) WYSTARCZY, BY ATRYBUTY BYLY WLASNE W OBIEKTACH C W CIAGU SL DLA PROTOTYPU AKTUALNEGO ORAZ POMIEDZY C TYMI OBIEKTAMI NIE WYSTEPUJA ZADNE KLASY ( ORAZ C OBIEKT Z TYPEM JEST TEN SAM) C (D) ATRYBUTY SA LOKALNE W PROTOTYPIE AKTUALNYM C (E) TYP NIE JEST ATRYBUTEM KLASY C******************************************** C MTPCON = 0 IF (TRBAS .NE. TLBAS) RETURN MTPCON = -1 IF ( (PRFXR .LE. 0) .OR. (PRFXL .LE. 0) ) RETURN C******************************************** C BADANIE WARUNKOW (A) - (E) MTPCON = 1 IF (PRFXR .EQ. PRFXL) RETURN C --POWROT DLA PRZYPADKU (A) SLOBR = IPMEM(TRBAS - 1) IF (IPMEM(SLOBR) .GT. 15) RETURN C --POWROT DLA PRZYPADKU (E) C......ODNALEZIENIE W LANCUCHU SL DLA PROTOTYPU AKTUALNEGO C P OBIEKTOW "PREFIKSOWANYCH" PRZEZ PROTOTYPY PRFXL I C PRFXR STOB = P PRFX1 = PRFXR PRFX2 = PRFXL CALL MOBJFD SLOBR = SLOB1 SLOBL = SLOB2 C SLOB - OBIEKTY W LANCUCHU SL C WCL1 = .TRUE. GDY POMIEDZY P A DRUGIM Z TYCH OBIEKTOW C WYSTEPUJE KLASA C WCL2 = .TRUE. GDY POMIEDZY TYMI OBIEKTAMI WYSTEPUJE C KLASA IF ( (SLOBR .EQ. P) .AND. (SLOBL .EQ. P) ) RETURN C --POWROT DLA PRZYPADKU (D) C MTPCON = -1 IF (WCL2) RETURN C --POMIEDZY OBIEKTAMI WYSTAPILA KLASA C C......TESTOWANIE PRZYPADKU (C) IF ( (PRFXR .NE. SLOBR) .OR. (PRFXL .NE. SLOBL) ) X GOTO 100 STOB = SLOBR PRFX1 = IPMEM(TRBAS-1) PRFX2 = 0 CALL MOBJFD OBTPR = SLOB1 C STOB = SLOBL PRFX1 = IPMEM(TLBAS-1) PRFX2 = 0 CALL MOBJFD OBTPL = SLOB1 IF (OBTPR .NE. OBTPL) RETURN MTPCON = 1 RETURN C......TESTOWANIE PRZYPADKU (B) C ODSZUKANIE OBIEKTOW, Z KTORYCH BRANY JEST TYP, GDY C OTOCZENIAMI SA SLOB 100 IF (WCL1) RETURN IF (IAND(IPMEM(P), 15) .NE. 1) RETURN C BY TYP NA PEWNO POCHODZIL Z TEGO SAMEGO OBIEKTU - P NIE MOZE BYC C KLASA STOB = SLOBR PRFX1 = IPMEM(TRBAS-1) PRFX2 = 0 CALL MOBJFD OBTPR = SLOB1 IF (WCL1 .AND. (SLOBR .NE. OBTPR) ) RETURN STOB = SLOBL PRFX1 = IPMEM(TLBAS-1) PRFX2 = 0 CALL MOBJFD OBTPL = SLOB1 IF (WCL1 .AND. (SLOBL .NE. OBTPL) ) RETURN IF (OBTPL .NE. OBTPR) RETURN C --TYP BRANY Z ROZNYCH OBIEKTOW MTPCON = 1 RETURN END *DECK MDISTP LOGICAL FUNCTION MDISTP (VSL, NRPROT, NRDIS) C-------------FUNKCJA SPRAWDZA, CZY TYP FORMALNY OBIEKTU DOSTEPNEGO C PRZEZ DISPLAY Z PROTOTYPU AKTUALNEGO JEST ROWNIEZ C DOSTEPNY PRZEZ DISPLAY C VSL - NUMER PROTOTYPU Z DEKLARACJA OBIEKTU C NRPROT - NUMER PROTOTYPU TYPU FORMALNEGO C /WYNIKI : NRDIS IDENTYFIKATOR PROTOTYPU, KTOREGO C NUMER W DISPLAY-U TWORZY ADRES NRPROT C /WARTOSCI C - .TRUE. - TYP ZAWSZE DOSTEPNY PRZEZ DISPLAY C - .FALSE. - TYP NIE JEST LUB NIE ZAWSZE JEST DOSTEPNY C PRZEZ DISPLAY C C OPIS W DOKUMENTACJI: ?1.4.4 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 314 C............................................................................. C C IMPLICIT INTEGER (A-Z) LOGICAL BPREF LOGICAL WCL, VWCL cdsw DATA MDISTPHX /Z0FFF/ C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL MOB C......KOMUNIKACJA Z PROCEDURA MOBJFD LOGICAL WCL1,WCL2 COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2 C C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !! C cdsw --------------------- data mdishx / x'0fff'/ cdsw ----------------------- TPSL = IPMEM(NRPROT - 1) NRDIS = TPSL C WARSTWA, Z KTOREJ POCHODZI TYP NRPROT MDISTP = .TRUE. IF (VSL .EQ. TPSL) RETURN IF (IAND(IPMEM(TPSL), mdishx ) .GT. 15) RETURN C OBYDWIE WIELKOSCI POCHODZA Z TEJ SAMEJ WARSTWY LUB TYP NIE C JEST ATRYBUTEM KLASY MDISTP = .FALSE. C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO C OBIEKTU Z WARSTWA VSL STOB = P PRFX1 = VSL PRFX2 = 0 CALL MOBJFD VOB = SLOB1 VWCL = WCL2 C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO C OBIEKTU Z WARSTWA TPSL STOB = P PRFX1 = TPSL CALL MOBJFD TOB = SLOB1 WCL = WCL2 IF (TOB .EQ. VOB) GOTO 100 IF (VWCL) RETURN IF (WCL) RETURN C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU VOB OBIEKTU C Z WARSTWA TPSL STOB = VOB PRFX1 = TPSL CALL MOBJFD TOBPR = SLOB1 WCL = WCL2 IF ( TOB .NE. TOBPR) GOTO 300 IF ( .NOT. WCL) GOTO 200 NRDIS = VOB IF (VOB .NE. TOB) RETURN MDISTP = .TRUE. RETURN 100 MDISTP = .TRUE. NRDIS = VSL RETURN 200 NRDIS = TOBPR MDISTP = .TRUE. RETURN 300 IF (IAND(IPMEM(VOB),15) .NE. 1) RETURN IF (WCL) RETURN IF (IAND(IPMEM(P), 15) .NE. 1) RETURN IF (IAND(IPMEM(TOBPR), 15) .EQ. 1) GOTO 200 IF (BPREF(TOB, IPMEM(TOBPR-6))) RETURN GOTO 200 C JESLI P I VOB NIE SA KLASAMI ORAZ TOB NIE JEST ROWN TOBPR A TALZE C POMIEDZY VOB A TOBPR NIE MA KLAS - TYP JEST WIDOCZNY PRZEZ DISPLAY C DODATKOWY WARUNEK: TOB NIE MOZE BYC PREFIKSOWANE PRZEZ TOBPR END *DECK MOBJFD SUBROUTINE MOBJFD C POMOCNICZA PROCEDURA PRZY KONTROLI TYPOW. C WYSZUKUJE W LANCUCHU SL OBIEKTU STOB OBIEKTY C "PREFIKSOWANE" (LUB ROWNE) PRZEZ PRFX1 I PRFX2 C (JESLI PRFX2=0 TO TYLKO PRFX1) C SLOB1 - OBIEKT ZAWIERAJACY WARSTWE PRFX1 C SLOB2 - OBIEKT ZAWIERAJACY WARSTWE PRFX2 C WCL1 = .TRUE. JESLI POMIEDZY STOB A TYMI OBIEKTAMI C WYSTEPUJE KLASA C WCL2 = .TRUE. JESLI POMIEDZY TYMI OBIEKTAMI WYSTE- C PUJE KLASA C C OPIS W DOKUMENTACJI: ?1.4.3 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 548 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL WCLPR, NOCL1, NOCL2, BPREF cdsw DATA MOBJFDHX /Z0FFF/ C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C *CALL MOB C......KOMUNIKACJA Z PROCEDURA MOBJFD LOGICAL WCL1,WCL2 COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2 C C !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14 !! C cdsw ------------------- data mobjhx / x'0fff'/ cdsw --------------------- C......INICJALIZACJA ACTOB = STOB C -OBIEKT AKTUALNY W LANCUCHU SL WCL1 = .FALSE. WCL2 = .FALSE. WCLPR = .FALSE. C......SPRAWDZENIE, CZY PRFX SA KLASAMI JESLI TAK TO POBRANIE C ICH NUMEROW W SENSIE ZBIOROW PREFIKSOW NOCL1 = .TRUE. NOCL2 = .TRUE. ZWORD = IAND(IPMEM(PRFX1), 15) IF ( (ZWORD .GE. 15) .OR. (ZWORD .EQ. 1) ) X GOTO 100 NOCL1 = .FALSE. PRFN1 = IPMEM(PRFX1-6) C --PRFN1 - NUMER W SENSIE PREFXSET C 100 IF (PRFX2 .EQ. 0) GOTO 3000 C --SKOK DO WYSZUKIWANIA PROTOTYPU Z WARSTWA PRFX1 C C IF ( (IPMEM(PRFX2) .GE. 15) .OR. (IPMEM(PRFX2) .EQ. 1) ) X GOTO 200 NOCL2 = .FALSE. PRFN2 = IPMEM(PRFX2-6) C 200 CONTINUE IF (PRFX1 .EQ. PRFX2) GOTO 3100 C C************WYSZUKIWANIE BLIZSZEGO OBIEKTU 1000 IF (ACTOB .EQ. PRFX1) GOTO 2000 IF (ACTOB .EQ. PRFX2) GOTO 3000 IF (IPMEM(ACTOB) .EQ. 1) GOTO 1600 IF ( IAND(ISHFT(IPMEM(ACTOB), -8), 7) .EQ. 7) GOTO 1600 C --OMINIECIE BLOKU ZWYKLEGO I HANDLERA IF (NOCL1) GOTO 1100 IF (BPREF(ACTOB,PRFN1)) GOTO 2000 1100 IF (NOCL2) GOTO 1500 IF (BPREF(ACTOB,PRFN2)) GOTO 3000 C......POBRANIE KOLEJNEGO OBIEKTU Z LANCUCHA SL (PRZY C JEDNOCZESNYM SPRAWDZENIU, CZY NIE JEST TO KLASA) 1500 IF (ACTOB .EQ. STOB) GOTO 1600 IF ( IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL1 = .TRUE. 1600 ACTOB = IPMEM(ACTOB-1) GOTO 1000 C C C******WYSZUKIWANIE DRUGIEGO OBIEKTU, W PRZYPADKU GDY C PIERWSZYM JEST ODPOWIADAJACY PRFX1 2000 SLOB1 = ACTOB IF ( (IPMEM(ACTOB) .LE. 15) .AND. (IPMEM(ACTOB) .NE. 1) ) X WCLPR = .TRUE. C ***BADANIE KOLEJNYCH OBIEKTOW 2100 CONTINUE IF (ACTOB .EQ. PRFX2) GOTO 2500 IF (IPMEM(ACTOB) .EQ. 1) GOTO 2300 IF (IAND(ISHFT(IPMEM(ACTOB), -8), 7) .EQ. 7) GOTO 2300 IF (NOCL2) GOTO 2200 IF (BPREF(ACTOB, PRFN2)) GOTO 2500 2200 IF (ACTOB .EQ. SLOB1) GOTO 2300 IF (IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL2 = .TRUE. 2300 ACTOB = IPMEM(ACTOB-1) GOTO 2100 C C C ***OBIEKT DRUGI ODNALEZIONY 2500 SLOB2 = ACTOB IF ( SLOB1 .EQ. SLOB2) RETURN WCL1 = ( (WCL1 .OR. WCL2) .OR. WCLPR) RETURN C C C******WYSZUKIWANIE DRUGIEGO OBIEKTU W PRZYPADKU, GDY PIERWSZYM C JEST ODPOWIADAJACY PRFX2 (ROWNIEZ, GDY SZUKAMY JEDNEGO C OBIEKTU) 3000 SLOB2 = ACTOB ZWORD = IAND(IPMEM(ACTOB), mobjhx ) IF ( (ZWORD .LE. 15) .AND. (ZWORD .NE. 1) ) X WCLPR = .TRUE. C ***BADANIE KOLEJNYCH OBIEKTOW W CIAGU SL 3100 CONTINUE IF (ACTOB .EQ. PRFX1) GOTO 3500 IF (IPMEM(ACTOB) .EQ. 1) GOTO 3300 IF (NOCL1) GOTO 3200 IF (BPREF(ACTOB, PRFN1)) GOTO 3500 3200 IF (ACTOB .EQ. SLOB2) GOTO 3300 IF (IAND(IPMEM(ACTOB), mobjhx ) .LE. 15) WCL2 = .TRUE. 3300 ACTOB = IPMEM(ACTOB-1) GOTO 3100 C C C ***ODNALEZIONY DRUGI OBIEKT 3500 SLOB1 = ACTOB IF (PRFX1 .NE. PRFX2) GOTO 3600 WCL2 = .FALSE. SLOB2 = ACTOB 3600 CONTINUE IF (SLOB1 .EQ. SLOB2) RETURN C GDY OBA PREFIKSY PREFIKSUJA PIERWSZA NAPOTKANA C KLASE TO NIE TRAKTUJEMY JEJ JAKO KLASY (TZN. C WCL1 I WCL2 SA .FALSE. WCL1 = ( (WCL1 .OR. WCL2) .OR. WCLPR) RETURN END *DECK MARITH SUBROUTINE MARITH ( OP ) C-------------PROCEDURA BADA POPRAWNOSC ARGUMENTOW OPERACJI ARYTME- C TYCZNYCH. C TYPY LEWEGO I PRAWEGO ARGUMENTU DANE SA W BLOKU /SEMANT/ C PRZEZ ZMIENNE TLDIM, TLBAS ORAZ TRDIM,TRBAS . C ZMIENNE IDL I IDR (W /SEMANT/) SA IDENTYFIKATORAMI LEWE- C GO I PRAWEGO ARGUMENTU (DO SYGNALIZACJI BLEDOW). C PARAMETR OP OKRESLA RODZAJ OPERACJI: C OP = 1 - DLA +,-,* ORAZ RELACJI <,>,<=,>= C OP = 2 - DLA DIV I MOD C OP = 3 - DLA / (WYNIK ZAWSZE REAL) C NA ZMIENNA TRESLT W /SEMANT/ PODSTAWIANY JEST TYP C WYNIKU OPERACJI . C PROCEDURA PRZEKAZUJE INFORMACJE O KONWERSJI LEWEGO (CONVL) C I PRAWEGO (CONVR) ARGUMENTU. WARTOSCI TYCH ZMIENNYCH C OZNACZAJA : C 0 - BEZ KONWERSJI C 1 - INTEGER DO REAL C ----SYGNALIZOWANE BLEDY : C 604 - TYP ARGUMENTU OPERACJI LUB RELACJI NIE JEST ARYTME- C TYCZNY, C 605 - TYP ARGUMENTU DIV LUB MOD NIE JEST INTEGER C C OPIS W DOKUMENTACJI: ?2.4 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 295 C............................................................................. C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C C C------ KONTROLA TYPU LEWEGO ARGUMENTU TL = TLBAS IF (TLDIM .NE. 0) GOTO 100 C SKOK - GDY JEST TO TYP TABLICOWY IF ((TLBAS .EQ. NRINT) .OR. (TLBAS .EQ. NRRE) .OR. X (TLBAS .EQ. NRUNIV) ) GOTO 200 C C...... TYP LEWEJ STRONY NIE JEST ARYTMETYCZNY 100 TL = NRUNIV CALL MERR(604, IDL) C C------KONTROLA TYPU PRAWEJ STRONY 200 TR = TRBAS IF (TRDIM .NE. 0) GOTO 300 IF ((TRBAS .EQ. NRINT) .OR. (TRBAS .EQ. NRRE) .OR. X (TRBAS .EQ. NRUNIV) ) GOTO 400 C C......TYP PRAWEJ STRONY NIE JEST ARYTMETYCZNY 300 TR = NRUNIV CALL MERR(604, IDR) C C C------ SPRAWDZENIE ZALEZNE OD RODZAJU OPERACJI, USTALENIE KONWERSJI 400 IF (OP-2) 500, 600, 700 C C..... OP = 1 - OPERACJE +,-,* ORAZ RELACJE 500 TRESLT = NRRE C TYP REAL JEST SILNIEJSZY OD INTEGER. PRZYJMUJE WIEC, ZE JEST C TO TYP WYNIKU. IF (TL .EQ. TR) TRESLT = TL IF ((TR .EQ. NRUNIV) .OR. (TL .EQ. NRUNIV)) TRESLT = NRUNIV C TYP WYNIKU JEST JUZ USTALONY C PODANIE INFORMACJI O KONWERSJI CONVL = 0 IF (TL .NE. TRESLT) CONVL = 1 CONVR = 0 IF (TR .NE. TRESLT) CONVR = 1 RETURN C C..... OP = 2 - OPERACJE DIV I MOD 600 TRESLT = NRINT CONVL = 0 CONVR = 0 C SPRAWDZENIE, CZY TYPY ARGUMENTOW NIE SA REAL IF (TL .EQ. NRRE) CALL MERR(605, IDL) IF (TR .EQ. NRRE) CALL MERR(605, IDR) RETURN C C...... OP = 3 - OPERACJA / C WYNIK MUSI BYC TYPU REAL, ARGUMENTY PODLEGAJA EWENTUALNEJ C KONWERSJI 700 TRESLT = NRRE CONVL = 0 CONVR = 0 IF (TL .EQ. NRINT) CONVL = 1 IF (TR .EQ. NRINT) CONVR = 1 RETURN END *DECK MLOCTP LOGICAL FUNCTION MLOCTP (TP, PROT) C-------------FUNKCJA SPRAWDZA, CZY TYP TP JEST LOKALNYM ATRYBUTEM C PROTOTYPU PROT C C OPIS W DOKUMENTACJI: ?1.4.2 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 107 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL BPREF C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! MLOCTP = .TRUE. C SLTP = IPMEM(TP - 1) C SLTP - MIEJSCE DEKLARACJI TP IF (SLTP .EQ. PROT) RETURN MLOCTP = .FALSE. IF ( IAND( IPMEM(SLTP), 15) .EQ. 1) RETURN C POWROT Z WARTOSCIA .FALSE. O ILE SLTP NIE MOZE PREFIKSOWAC C PROTOTYPU PROT IF ( IPMEM(PROT) .EQ. 1) RETURN IF ( IAND(ISHFT(IPMEM(PROT), -8), 7) .EQ. 7) RETURN C --HANDLER IF ( BPREF (PROT, IPMEM(SLTP - 6) ) ) MLOCTP = .TRUE. RETURN END *DECK MAQUAB INTEGER FUNCTION MAQUAB ( IDB ) C-------------FUNKCJA BADA POPRAWNOSC KONSTRUKCJI QUA IDB . C TLDIM I TLBAS OKRESLAJA TYP WYRAZENIA PRZED QUA. IDL JEST C NAZWA TEGO WYRAZENIA UZYWANA PRZY SYGNALIZACJI BLEDOW. C IDB JEST NAZWA ZE SCANNERA WYSTEPUJACA PO QUA . C // WARTOSCIA FUNKCJI JEST PROTOTYP ODPOWIADAJACY IDB C LUB NRUNIV W PRZYPADKU BLEDOW. C NAZWA IDB JEST WYSZUKIWANA W OTOCZENIU PROTOTYPU C AKTUALNEGO (P Z BLOKU /SEMANT/). C ----SYGNALIZOWANE BLEDY C 600 (Z PROCEDURY MIDENT) - NIEDOSTEPNY IDENTYFIKATOR IDB C PODOBNIE 619 I 620 C 615 - TYP PRZED QUA NIE JEST KLASA UOGOLNIONA ANI TYPEM C FORMALNYM C 616 - IDENTYFIKATOR PO QUA NIE JEST TYPEM C 617 - IDENTYFIKATOR PO QUA NIE JEST TYPEM KLASOWYM C 618 - TYP PO QUA NIE JEST W SEKWENCJI PREFIKSOWEJ Z TLBAS C C C OPIS W DOKUMENTACJI: ?1.5.2 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 238 C............................................................................. IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C C ODSZUKIWANIE IDENTYFIKATORA MAQUAB = MIDENT (IDB) C C......SPRAWDZENIE, CZY IDB JEST TYPEM KLASOWYM IGT = IAND ( IPMEM(MAQUAB), 15) GOTO (1000, 100, 100, 2000, 100, 200, 100, 200, 200, 200, X 200, 200, 200, 200), IGT C C ...IDB JEST KLASA LUB TYPEM SYSTEMOWYM - GDY TO TYP SYSTEMOWY C TO BLAD 100 IF ( (MAQUAB .NE. NRCOR) .AND. (MAQUAB .NE. NRPROC) ) X GOTO 2000 C SKOK - GDY JEST TO ZWYKLY TYP KLASOWY C C ...IDB NIE JEST TYPEM KLASOWYM 200 CALL MERR(617, IDB) MAQUAB = NRUNIV GOTO 2000 C C ...IDB NIE JEST TYPEM 1000 CALL MERR(616, IDB) MAQUAB = NRUNIV C C......BADANIE TYPU PRZED QUA 2000 IF (TLDIM .NE. 0) GOTO 3000 C SKOK - GDY PRZED QUA TYP TABLICOWY IGT = IAND( IPMEM(TLBAS), 15) GOTO (3000, 2100, 2100, 4000, 2100, 2200, 2100, 3000, 3000, X 3000, 3000, 3000, 3000, 3000), IGT C C ...PRZED QUA TYP KLASOWY LUB SYSTEMOWY 2100 IF (MAQUAB .EQ. NRUNIV) RETURN IF ( (TLBAS .EQ. NRCOR) .OR. (TLBAS .EQ. NRPROC) ) RETURN IF (MPRFSQ (TLBAS, MAQUAB) .GE. 0) RETURN C TU - GDY SEKWENCJE PREFIKSOWE TYPOW KLASOWYCH SA ROZLACZNE CALL MERR(618, IDB) MAQUAB = NRUNIV RETURN C C ...TYP PRZED QUA JEST FORMALNY 2200 RETURN C C ...TYP PRZED QUA NIE JEST ODPOWIEDNI 3000 CALL MERR(615, IDL) MAQUAB = NRUNIV 4000 RETURN END *DECK MTHIS INTEGER FUNCTION MTHIS (ID) C-------------FUNKCJA BADA POPRAWNOSC KONSTRUKCJI THIS ID, GDZIE C ID JEST NAZWA ZE SCANNERA. KONSTRUKCJA WYSTEPUJE W MODU- C LE O PROTOTYPIE AKTUALNYM P (Z BLOKU /SEMANT/). C // WARTOSCIA FUNKCJI JEST PROTOTYP ID C W PRZYPADKU BLEDU - WARTOSCIA JEST PROTOTYP UNIWERSALNY. C ----SYGNALIZOWANE BLEDY C 600 (Z PROCEDURY MIDENT) - NIEDOSTEPNY IDENTYFIKATOR ID C PODOBNIE 619 I 620 C 612 - ID NIE WYSTEPUJE W SEKWENCJI PREFIKSOWEJ ZADNEGO C MODULU OBEJMUJACEGO P C 613 - ID NIE JEST NAZWA KLASY UOGOLNIONEJ C 614 - ID NIE JEST NAZWA TYPU C C OPIS W DOKUMENTACJI: ?1.5.1 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 182 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL BPREF C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C C MTHIS = MIDENT (ID) IF (MTHIS .EQ. NRUNIV) RETURN C IGT = IAND (IPMEM(MTHIS), 15) GOTO (9000, 100, 100, 9000, 100, 8000, 100, 8000, 8000, X 8000, 8000, 8000, 8000, 8000), IGT C C-----PRZYPADEK, GDY ID JEST NAZWA TYPU KLASOWEGO LUB SYSTEMOWEGO C PRZEJSCIE PO SL-ACH W POSZUKIWANIU MODULU PREFIKSOWANEGO C PRZEZ ID C PROT - PROTOTYP BADANY 100 PROT = P NRPRF = IPMEM(MTHIS - 6) C NRPRF - NUMER PROTOTYPU W SENSIE ZBIORU PREFIKSOW 200 ZWORD = IPMEM(PROT) C ZWORD - SLOWO ZEROWE PROTOTYPU PROT - DO KONTROLI, CZY NIE C JEST TO BLOK ZWYKLY, W POZOSTALYCH PRZYPADKACH BADAMY WARUNEK C PREFIKSOWANIA IF (ZWORD .EQ. 1) GOTO 250 C SKOK - OMIJA BLOK ZWYKLY IF (IAND(ISHFT(ZWORD, -8), 7) .EQ. 7) GOTO 250 C SKOK - OMIJA PROTOTYP HANDLERA IF (BPREF(PROT, NRPRF) ) RETURN C POWROT JESLI PROT JEST PREFIKSOWANY PRZEZ ID 250 PROT = IPMEM(PROT-1) IF (PROT .NE. NBLSYS) GOTO 200 C ITEROWANIE - GDY NIE DOSZLISMY DO BLOKU SYSTEMOWEGO C.....ID NIE WYSTAPILO W SEKWENCJI PREFIKSOWEJ CALL MERR(612, ID) MTHIS = NRUNIV RETURN C.....ID WYSTAPILO JAKO PREFIKS PROTOTYPU PROT C C-----ID NIE JEST NAZWA KLASY UOGOLNIONEJ 8000 CALL MERR(613, ID) MTHIS = NRUNIV RETURN C C C-----ID NIE JEST TYPEM 9000 CALL MERR(614, ID) MTHIS = NRUNIV RETURN END *DECK MDOT INTEGER FUNCTION MDOT(TDIM, TBAS, IDA, ID) C-------------FUNKCJA BADAJACA POPRAWNOSC WYRAZENIA KROPKOWANEGO C TDIM, TBAS - TYP WYRAZENIA PRZED KROPKA, C IDA - IDENTYFIKATOR WYRAZENIA PRZED KROPKA (DO SYGNALIZA- C CJI BLEDOW), C ID - NAZWA ZE SCANNERA IDENTYFIKATORA PO KROPCE. C JESLI ATRYBUT JEST DOSTEPNY - WARTOSCIA MDOT JEST JEGO C OPIS. C JESLI ATRYBUT JEST NIEDOSTEPNY (NIEZADEKLAROWANY LUB C "CLOSE") - WARTOSCIA (PO ZASYGNALIZOWANIU BLEDU) JEST C ATRYBUT UNIWERSALNY. JESLI ATRYBUT BYL NIEZADEKLAROWANY C - JEST ON WPROWADZANY. C ----SYGNALIZOWANE BLEDY C 601 - BLEDNY TYP PRZED KROPKA (PRYMITYWNY, FORMALNY, C SYSTEMOWY LUB TABLICOWY), C 602 - IDENTYFIKATOR PO KROPCE JEST "CLOSE", HIDDEN LUB NIE JEST C TAKEN, C 603 - IDENTYFIKATOR PO KROPCE NIE JEST ZADEKLAROWANY, C 611 - PO KROPCE WYSTEPUJE IDENTYFIKATOR STALEJ "CONST". C 621 - PO KROPCE WYSTEPUJE IDENTYFIKATOR HIDDEN LUB SPOZA C LISTY TAKEN C C OPIS W DOKUMENTACJI: ?1.6.1 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 382 C............................................................................. C IMPLICIT INTEGER (A-Z) LOGICAL MINSCP C FUNKCJA POMOCNICZA DO BADANIA, CZY JESTESMY W ZASIEGU DEKLARACJI C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C *CALL MEM C..... C KOMUNIKACJA Z PROCEDURA MEMPRF COMMON /MEM/ NM, NH C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !! C C IF (TDIM .NE. 0) GOTO 1000 C C------ TU TYPY NIETABLICOWE TP = IAND(IPMEM(TBAS), 15) C TP - POLE T Z OPISU TYPU TBAS C GOTO (1000, 100, 100, 500, 400, 1000, 400, 1000, 1000, 1000, X 1000, 1000, 1000, 1000, 1000), TP C C------ TYPY POSIADAJACE ATRYBUTY (TZN. TYPY KLASOWE) 100 NM = ID NH = IAND ( ISHFT(NM, -1), 7) + 1 MDOT = MEMPRF (TBAS) IF (MDOT .NE. 0) GOTO 200 C------ TU - IDENTYFIKATOR NIEZADEKLAROWANY CALL MERR(603, ID) MDOT = INSERT(ID, IPMEM(TBAS+10), 0) MDOT = NRUNIV RETURN C------ TU - GDY IDENTYFIKATOR WYSTEPUJE (LUB BYL DODEKLAROWANY) 200 IF (IPMEM(MDOT+1) .EQ. 0) GOTO 220 C SKOK - IDENTYFIKATOR JEST DOSTEPNY I NIE JEST CHRONIONY IF ( IPMEM(MDOT+1) .EQ. 1 ) GOTO 300 C SKOK - JESLI IDENTYFIKATOR JEST "CLOSE" IF (IPMEM(MDOT+1) .EQ. 4) GOTO 250 C SKOK - JESLI IDENTYFIKATOR JEST 'NOT TAKEN' C ---TU IDENTYFIKATOR JEST 'HIDDEN' IF (.NOT. OWN) GOTO 250 C ---TERAZ NALEZY SPRAWDZIC, CZY IDENTYFIKATOR NIE BYL 'CLOSE' JUZ C W PREFIKSIE IF (IPMEM(TBAS+19) .EQ. 0) GOTO 210 C ---TBAS JEST NIEPREFIKSOWANY PRID = MEMPRF (TBAS+19) IF (PRID .EQ. 0) GOTO 210 IF (IPMEM(PRID+2) .NE. IPMEM(MDOT+2)) GOTO 210 C ---IDENTYFIKATOR NIE BYL DEKLAROWANY W PREFIKSIE IF (IPMEM(PRID+1) .EQ. 1) GOTO 250 C ---SKOK - IDENTYFIKATOR BYL 'CLOSE' JUZ W PREFIKSIE C---SPRAWDZENIE, CZY JESTESMY W ZASIEGU DEKLARACJI MODULU CHRONIACEGO ATRYBUT 210 IF (.NOT. MINSCP(TBAS)) GOTO 250 220 MDOT = IPMEM(MDOT+2) RETURN C C------ TU IDENTYFIKATORY "HIDDEN" LUB "NOT TAKEN" 250 CALL MERR(621, ID) IF (.NOT. OWN) NRE = INSERT(ID, IPMEM(TBAS+10), 0) IF (OWN .AND. (IPMEM(MDOT+1) .LT. 4) ) GOTO 255 IPMEM(MDOT+1) = 0 IPMEM(MDOT+2) = NRUNIV 255 MDOT = NRUNIV RETURN C C C------ TU IDENTYFIKATORY "CLOSE" LUB STALE "CONST" 300 NRE = 602 NM = IPMEM(MDOT+2) IF (NM .EQ. NRUNIV) GOTO 350 C --BADANIE, CZY TO STALA 'CONST' NM = ISHFT( IPMEM(NM), -4) NM = IAND(NM, 15) IF (NM .NE. 8) GOTO 350 NRE = 611 GOTO 360 350 IF (.NOT. OWN) GOTO 360 IF (MINSCP(TBAS)) GOTO 220 360 CALL MERR(NRE, ID) IF (.NOT. OWN) NRE = INSERT(ID, IPMEM(TBAS+10), 0) MDOT = NRUNIV RETURN C C------OBIEKTY COROUTINE LUB PROCESS 400 IF ((TBAS .NE. NRCOR) .AND. (TBAS .NE. NRPROC)) GOTO 100 C C------NIEPOPRAWNY TYP PRZED KROPKA 1000 CALL MERR(601, IDA) C------ TYP PRZED KROPKA JEST UNIWERSALNY 500 MDOT = NRUNIV RETURN END *DECK MINSCP LOGICAL FUNCTION MINSCP (T) C-----------------FUNKCJA BADA,CZY PROTOTYP AKTUALNY JEST WEWENATRZ C DEKLARACJI MODULU T, TZN. CZY T LEZY W LANCUCHU SL C PROTOTYPU P C C.................................................................... C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C MINSCP = .TRUE. PR = P 100 IF (PR .EQ. T) RETURN IF (PR .EQ. NBLSYS) GOTO 200 PR = IPMEM(PR-1) GOTO 100 200 MINSCP = .FALSE. RETURN END *DECK MPROTO SUBROUTINE MPROTO C---------------------------------PROCEDURA POMOCNICZA - OTWIERA POMOCNICZA C STRUKTURE DANYCH PRZY WEJSCIU DO INSTRUKCJI NOWEGO C PROTOTYPU C C............................................................................ C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! *CALL MID COMMON /MID/ PSTART, CHECKS C C CHECKS = 0 INSYS = .TRUE. PSTART = MGETM(8,0) INSYS = .FALSE. RETURN END *DECK MPROTC SUBROUTINE MPROTC C---------------------------------PROCEDURA POMOCNICZA - ZAMYKA POMOCNICZA C STRUKTURE DANYCH PRZY WYJSCIU Z PROTOTYPU C C........................................................................ C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! *CALL MID COMMON /MID/ PSTART, CHECKS C C LPML = PSTART RETURN END *DECK MIDENT INTEGER FUNCTION MIDENT(ID) C-------------------------------FUNKCJA WYSZUKUJE W PROTOTYPIE AKTUALNYM P C I JEGO OTOTCZENIU NAZWE ID (HASH ZE SCANNERA). C WYSZUKIWANIE ODBYWA SIE NAJPIERW W STRUKTURZE C POMOCNICZEJ C C............................................................................. C IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! *CALL MID COMMON /MID/ PSTART, CHECKS C C C *****SZUKANIE NAZWY W LOKALNEJ STRUKTURZE DANYCH MIDENT = MEMBER(ID, IPMEM(PSTART)) IF (MIDENT .EQ. 0) GOTO 100 C ----NAZWA ODNALEZIONA - NA PEWNO JEST POPRAWNA, NIE TRZEBA SYGNALIZOWAC C ZADNYCH BLEDOW C NALEZY JEDYNIE USTAWIC ZMIENNE INFORMUJACE O DOSTEPIE OBJECT = IPMEM(MIDENT+1) LOCAL = IPMEM(MIDENT+4) MIDENT = IPMEM(MIDENT+2) OWN = (LOCAL .LT. 0) IF (OWN) LOCAL = -LOCAL-1 RETURN C ----NAZWA NIE ZOSTALA ODNALEZIONA - SZUKANIE PRZY POMOCY MIDB 100 MIDENT = MIDB(ID) C ----JESLI MOZEMY WSTAWIAC DO LISTY POMOCNICZEJ, TO WSTAWIAMY, WPP POWROT IF ((LPML+5) .GT. LPMF) CHECKS = CHECKS+1 IF (CHECKS .GT. 0) GOTO 200 INSYS = .TRUE. NADR = MGETM(5,0) INSYS = .FALSE. MIDENT = IPMEM(MIDENT+2) IPMEM(NADR) = ID IPMEM(NADR+1) = OBJECT IPMEM(NADR+2) = MIDENT IPMEM(NADR+4) = LOCAL IF (OWN) IPMEM(NADR+4) = -(LOCAL+1) NH = IAND(ISHFT(ID, -1), 7) + PSTART IPMEM(NADR+3) = IPMEM(NH) IPMEM(NH) = NADR RETURN 200 MIDENT = IPMEM(MIDENT+2) RETURN END *DECK MIDB INTEGER FUNCTION MIDB (ID) C-------------FUNKCJA WYSZUKUJE W PROTOTYPIE AKTUALNYM P ( /SEMANT/) C I JEGO OTOCZENIU NAZWE ID (HASH ZE SCANNERA). C (.) JESLI NAZWA TA JEST DOSTEPNA, TO : C -NADAJE ZMIENNEJ LOCAL WARTOSC C WYSTAPIENIA IDENTYFIKATORA), C -WARTOSCIA FUNKCJI JEST INDEKS OPISU TEGO IDENTYFIKA- C TORA . C (.) JESLI NAZWA NIE JEST DOSTEPNA LUB JEST NIEZADEKLAROWA- C NA - DODEKLAROWUJE JA, SYGNALIZUJE BLAD I NADAJE WAR- C TOSC ATRYBUTU UNIWERSALNEGO. C ----SYGNALIZOWANE BLEDY: C 600 - NIEZADEKLAROWANY (LUB NIEDOSTEPNY) IDENTYFIKATOR C 619 - UZYCIE IDENTYFIKATORA HIDDEN C 620 - UZYCIE IDENTYFIKATORA SPOZA LISTY TAKEN C C C OPIS W DOKUMENTACJI: ?1.4.1 C WERSJA Z DNIA: 19.01.82 C DLUGOSC KODU: 155 C............................................................................. IMPLICIT INTEGER (A-Z) C C *CALL BLANKSEM C..... #include "blank.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !! C C MIDB = MEMSL (ID, P) C MEMSL MA WARTOSC ZERO, JESLI NAZWA NIE ZOSTALA ODNALEZIONA C LUB JEST INDEKSEM W LISCIE HASH-U. C OWN MA WARTOSC .TRUE. - GDY IDENTYFIKATOR ZOSTAL ZNALEZIONY C BEZPOREDNIOW PROTOTYPIE (A NIE JEGO PREFIKSIE) - MOZE BYC C WTEDY HIDDEN . IF (MIDB .EQ. 0) GOTO 1000 C------TU PRZYPADEK NAZWY ODNALEZIONEJ C...... SPRAWDZENIE DOSTEPNOSCI IDENTYFIKATORA IF ( IPMEM(MIDB + 1) .GE. 4 ) GOTO 1200 C IDENTYFIKATOR NIE JEST NA LISCIE TAKEN IF ( (IPMEM(MIDB+1) .GE. 2) .AND. (.NOT. OWN) ) GOTO 1300 C IDENTYFIKATOR JEST HIDDEN W KTORYMS Z PREFIKSOW RETURN C C------TU PRZYPADEK NAZWY NIEODNALEZIONEJ 1000 CALL MERR(600, ID) C DODEKLAROWANIE NAZWY - ELEMENTU LISTY HASH-U 1100 MIDB = INSERT(ID, IPMEM(P+10), 0) LOCAL = 2 RETURN C C...... SYGNALIZACJE BLEDOW DLA NIEDOSTEPNYCH ATRYBUTOW 1200 CALL MERR(620, ID) IF (.NOT. OWN) GOTO 1100 IPMEM(MIDB+1) = 0 IPMEM(MIDB+2) = NRUNIV RETURN 1300 CALL MERR(619, ID) GOTO 1100 C END *NEWDECK MEMSL INTEGER FUNCTION MEMSL (NAME, IDPROT) C-------------WYSZUKUJE NAZWE NAME W PROTOTYPIE IDENTYFIKOWANYM PRZEZ C IDPROT ORAZ JEGO OTOCZENIU (PO SL-ACH). WARTOSCIA JEST C ELEMENT LISTY HASH-U Z TA NAZWA LUB 0 - GDY TEJ NAZWY C NIE BYLO. C / JESLI NAZWA WYSTAPILA BEZPOSREDNIO W IDPROT LUB JEGO C PREFIKSACH - WARTOSCIA C ZMIENNEJ LOCAL Z BLOKU // JEST 2, WPP 0 LUB 1 C / PO ODNALEZIENIU NAZWY ELEMENT PRZESUWANY NA POCZATEK C LISTY HASH-U. C / OWN MA WARTOSC .TRUE. JESLI NAZWA ODNALEZIONA JEST C BEZPOSREDNIO W PROTOTYPIE A NIE W PREFIKSIE. C TO ZNACZY TAM WYSTEPUJE W LISCIE - DO KONTROLI PROTEKCJI. C /OBJECT - PROTOTYP OBIEKTU, W KTORYM ODNALEZIONO ATRYBUT O C NAZWIE NAME C C OPIS W DOKUMENTACJI: B.III.2.4 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 117 C....................................................................... C IMPLICIT INTEGER (A-Z) C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C *CALL MEM C..... C KOMUNIKACJA Z PROCEDURA MEMPRF COMMON /MEM/ NM, NH C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !! C NM = NAME NH = IAND( ISHFT(NAME, -1), 7) + 1 C NH - WARTOSC FUNKCJI HASZUJACEJ DLA SZUKANEJ NAZWY C LOCAL = 2 ISL = IDPROT C ISL - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW C C ***** C C WYSZUKUJEMY W PREFIKSACH PROTOTYPU ISL 10 MEMSL = MEMPRF(ISL) IF (MEMSL .NE. 0) GOTO 20 C POWROT, GDY NAZWA JUZ ODNALEZIONA C C ..... NAZWA NIEODNALEZIONA W PROTOTYPIE ISL - POBRANIE NOWEGO PROTOTY- C PU IF (ISL .EQ. NBLSYS) GOTO 1000 C SKOK - JESLI DOSZLISMY DO BLOKU SYSTEMOWEGO NIE ZNAJDUJAC C NAZWY - BEDZIE TO POWROT ISL = IPMEM(ISL-1) LOCAL = 1 GOTO 10 C ***** C .... NAZWA ODNALEZIONA 20 IF (ISL .EQ. NBLUS) LOCAL = 0 RETURN C C .... NAZWA NIEODNALEZIONA 1000 MEMSL =0 RETURN END *DECK MEMPRF INTEGER FUNCTION MEMPRF ( IDPROT) C-------------WYSZUKUJE NAZWE NM W PROTOTYPIE IDENTYFIKOWANYM PRZEZ C IDPROT ORAZ JEGO PREFIKSACH. WARTOSCIA JEST C ELEMENT LISTY HASH-U Z TA NAZWA LUB 0 - GDY TEJ NAZWY C NIE BYLO. C / JESLI NAZWA WYSTAPILA BEZPOSREDNIO W IDPROT WARTOSCIA C / ZMIENNEJ OWN JEST .TRUE., JESLI W PREFIKSACH - .FALSE. C //PO ODNALEZIENIU NAZWY ELEMENT PRZESUWANY NA POCZATEK C LISTY HASH-U. C OPIS W DOKUMENTACJI: B.III.2.3 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 261 C....................................................................... C C IMPLICIT INTEGER (A-Z) C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C *CALL MEM C..... C KOMUNIKACJA Z PROCEDURA MEMPRF COMMON /MEM/ NM, NH C !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !! C C IPR = IDPROT OBJECT = IDPROT OWN = .TRUE. C IPR - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW C IF (IPMEM(IPR) .EQ. 1) GOTO 500 IF (IAND( ISHFT(IPMEM(IPR), -4), 15) .NE. 0) GOTO 500 C SKOK, GDY BYL TO ZWYKLY BLOK LUB PROTOTYP FORMALNY, NIE MA C WTEDY PRZEJSCIA PO PREFIKSACH IF (IAND(ISHFT(IPMEM(IPR), -8), 7) .EQ. 7) GOTO 500 C SKOK - GDY BYL TO PROTOTYP HANDLERA, NIE MA PRZEJSCIA PO PREFIKSACH C I,J - WSKAZNIKI PRZECHODZENIA PO LISCIE HASH-U - J AKTUALNY, C I POPRZEDNI C ***** 10 J = IPR+ NH+ 9 J = IPMEM(J) I = -1 C ..... SZUKANIE W PROTOTYPIE IPR 20 IF (J.EQ.0) GOTO 25 C SKOK - NAZWA NIEODNALEZIONA - POBIERAMY KOLEJNY PROTOTYP C IF (IPMEM(J).EQ. NM) GOTO 100 C SKOK - NAZWA ODNALEZIONA C I =J J = IPMEM (J+3) GOTO 20 C ..... C NAZWA NIEODNALEZIONA W PREFIKSIE IPR - POBRANIE NOWEGO C PREFIKSU C 25 OWN = .FALSE. C PRZEJSCIE DO PREFIKSU IPR = IPMEM(IPR+21) IF (IPR .NE. 0) GOTO 10 GOTO 1000 C C ***** C C ..... NAZWA ODNALEZIONA 100 MEMPRF = J OBJECT = IPMEM(J+2) C MIEJSCE DEKLARACJI OBJECT = IPMEM(OBJECT-1) IF (I.NE.-1) GOTO 110 RETURN C PRZESUNIECIE ELEMENTU NA POCZATEK LISTY 110 IPMEM(I+3) = IPMEM (J+3) I = IPR+ NH + 9 IPMEM(J+3) = IPMEM(I) IPMEM(I) = J RETURN C C.....BLOKI ZWYKLE, HANDLERY I PROTOTYPY FORMALNE 500 MEMPRF = MEMBER(NM, IPMEM(IPR+10)) RETURN C C C .... NAZWA NIEODNALEZIONA 1000 MEMPRF =0 RETURN END *DECK INSERT INTEGER FUNCTION INSERT (NAME, THASH, NROVF) C-------------WPROWADZA NOWY ELEMENT O KLUCZU NAME DO TABLICY HASH-U C THASH. DZIALA POPRAWNIE POD WARUNKIEM, ZE W TABLICY ELE- C MENT TAKI JESZCZE NIE WYSTAPIL. C WARTOSCIA INSERT JEST IDENTYFIKATOR TEGO ELEMENTU. C / WARTOSCI POCZATKOWE UTWORZONEGO ELEMENTU C POLE NAZWY - NAME C BITY HIDDEN, CLOSE, NOT TAKEN - 0 C IDENTYFIKATOR ATRYBUTU - NRUNIV C / NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA C C OPIS W DOKUMENTACJI: B.III.2.1 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 95 C....................................................................... C IMPLICIT INTEGER (A-Z) INTEGER THASH(8) C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C C ..... REZERWACJA PAMIECI NA ELEMENT LISTY HASH-U INSERT = MGETM(4, NROVF) C C ..... NADANIE WARTOSCI POCZATKOWYCH I DOLACZENIE DO LISTY HASH-1 IPMEM(INSERT) = NAME IPMEM(INSERT +2) = NRUNIV NH = IAND( ISHFT(NAME, -1), 7) + 1 IPMEM(INSERT+3) = THASH (NH) THASH(NH) = INSERT RETURN END *DECK MEMBER INTEGER FUNCTION MEMBER (NAME, THASH) C-------------SPRAWDZA, CZY W TABLICY HASH-U THASH WYSTEPUJE NAZWA C NAME. JESLI TAK - WARTOSCIA JEST IDENTYFIKATOR ELEMENTU C LISTY HASH-U Z TA NAZWA. JESLI NIE - WARTOSCIA JEST 0 . C / JESLI NAZWA WYSTAPILA - ELEMENT JEJ ODPOWIADAJACY JEST C PRZESUWANY NA POCZATEK LISTY. C C OPIS W DOKUMENTACJI: B.III.2.2 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 155 C...................................................................... C IMPLICIT INTEGER (A-Z) INTEGER THASH (8) C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! NH = IAND( ISHFT(NAME, -1), 7) + 1 C NH - WARTOSC FUNKCJI HASZUJACEJ - INDEKS W TABLICY THASH SLOWA C ZAWIERAJACEGO POCZATEK LISTY C C I,J - WSKAZNIKI PORUSZANIA SIE PO LISCIE C J - WSKAZNIK AKTUALNY, I - POPRZEDNI I=-1 J = THASH(NH) C 10 IF (J.EQ.0) GOTO 200 C SKOK - JESLI ATRYBUT NIE ZOSTAL ODNALEZIONY C IF (IPMEM(J) .EQ. NAME ) GOTO 100 C SKOK - JESLI ATRYBUT ODNALEZIONY I = J J = IPMEM(J+3) GOTO 10 C C ..... NAZWA ODNALEZIONA 100 MEMBER = J IF (I.NE. -1) GOTO 110 RETURN C PRZESUNIECIE ELEMENTU LISTY NA POCZATEK LISTY 110 IPMEM(I+3) = IPMEM(J+3) IPMEM(J+3) = THASH(NH) THASH(NH) = J RETURN C C ..... NAZWA NIEODNALEZIONA 200 MEMBER = 0 RETURN END *DECK MGETM INTEGER FUNCTION MGETM(ISIZE, NROVF) C-------------REZERWUJE W PAMIECI IPMEM ISIZE KOMOREK. WAROSCIA MGETM C JEST INDEKS PIERWSZEJ Z TYCH KOMOREK. C REZERWACJA JEST DOKONYWANA W CZESCI SYSTEMOWEJ JESLI WAR- C TOSC ZMIENNEJ INSYS (BLOK //) JEST .TRUE., W PRZE- C CIWNYM PRZYPADKU - W CZESCI UZYTKOWNIKA. C /// GDY REZERWACJA TA NIE JEST MOZLIWA - WYWOLYWANA JEST C PROCEDURA MDROP PRZERYWAJACA PROCES KOMPILACJI C NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA C C OPIS W DOKUMENTACJI: B.III.1 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 145 C........................................................................... C C ZAREZERWOWANA PAMIEC JEST WYZEROWANA C IMPLICIT INTEGER (A-Z) C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C IF ( (LPML+ISIZE) .GT. LPMF) GOTO 1000 C SKOK - GDY WOLNY OBSZAR JEST ZA MALY IF (INSYS) GOTO 100 C C ..... PRZYDZIAL PAMIECI W CZESCI UZYTKOWNIKA LPMF = LPMF - ISIZE DO 50 I = 1, ISIZE J = LPMF + I IPMEM(J) = 0 50 CONTINUE MGETM = LPMF + 1 GOTO 500 C C ..... PRZYDZIAL PAMIECI W CZESCI SYSTEMOWEJ 100 MGETM = LPML DO 150 I = 1, ISIZE J = LPML + I IPMEM(J - 1) = 0 150 CONTINUE LPML = LPML + ISIZE C.....SPRAWDZENIE WYKORZYSTANIA PAMIECI 500 X = LPMF-LPML IF (X .LT. COM(4)) COM(4) = X RETURN C C C ..... BRAK MIEJSCA W PAMIECI 1000 CALL MDROP(NROVF) C END *DECK MPRFSQ INTEGER FUNCTION MPRFSQ (IDPR1, IDPR2) C-------------BADA RODZAJ PREFIKSOWANIA TYPOW IDPR1 I IDPR2 C WARTOSCI C -1 - ROZLACZNE SEKWENCJE PREFIKSOWE C 0 - IDPR1 PREFIKSUJE IPR2 C +1 - IDPR2 PREFIKSUJE IDPR1 C OBA TYPY MOGA BYC TYPAMI UNIWERSALNYMI C C OPIS W DOKUMENTACJI: B.III.4.3 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 79 C........................................................................ C IMPLICIT INTEGER (A-Z) LOGICAL BPREF C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C K1 = IPMEM(IDPR1-6) K2 = IPMEM(IDPR2-6) C K1,K2 - NUMERY TYPOW W SENSIE PREFIXSET IF (BPREF(IDPR2, K1)) GOTO 20 IF (BPREF(IDPR1, K2)) GOTO 30 C C ..... ROZLACZNE SEKWENCJE PREFIKSOWE MPRFSQ = -1 RETURN C ..... IDPR1 PREFIKSUJE IDPR2 20 MPRFSQ = 0 RETURN C ..... IDPR2 PREFIKSUJE IDPR1 30 MPRFSQ = +1 RETURN C END *DECK BPREF LOGICAL FUNCTION BPREF (IDPROT, NRPREF) C-------------BPREF SPRAWDZA, CZY TYP IDENTYFIKOWANY PRZEZ IDPROT JEST C PREFIKSOWANY PRZEZ KLASE, KTOREJ NUMER W SENSIE PREFIXSET C JEST ROWNY NRPREF. C WARTOSC .TRUE. - JEST PREFIKSOWANY C C C OPIS W DOKUMENTACJI: B.III.4.1 C WERSJA Z DNIA: 19.03.82 (MJL) C DLUGOSC KODU: 255 C......................................................................... C IMPLICIT INTEGER (A-Z) LOGICAL BTEST C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C IF (NRPREF .GT. 47) GOTO 300 K=NRPREF/16 IF ( IAND(IPMEM(IDPROT), 15) .NE. 1) GOTO 100 BPREF = .FALSE. IF (IPMEM(IDPROT+21) .EQ. 0 ) RETURN K = IPMEM(IDPROT+21) -3-K GOTO 200 100 K=IDPROT-3-K 200 K=IPMEM(K) C K SLOWO W PREFIXSET, W KTORYM NALEZY ZBADAC BIT ODPOWIADAJACY C NRPREF C L=IAND(NRPREF,15) C L - NUMER TESTOWANEGO BITU - L = IMOD(NRPREF,16) C BPREF = BTEST (K,L) RETURN 300 BPREF = .TRUE. IPR = IDPROT IF (IAND(IPMEM(IPR), 15) .EQ. 1) IPR = IPMEM(IPR+21) IF (IPR .EQ. 0) GOTO 500 IF (IPR .EQ. NRUNIV) RETURN IDL = IPMEM(IPR+23) IPR = IPMEM(IPR+22) 400 PRFX= IPMEM(IPR) IF (IPMEM(PRFX-6) .EQ. NRPREF) RETURN IDL = IDL-1 IPR = IPR+1 IF (IDL .NE. 0) GOTO 400 500 BPREF = .FALSE. RETURN END SUBROUTINE MDROP(NROVFL) C-------------PROCEDURA PRZERYWA DZIALANIE MODULU. C WYWOLYWANA JEST W PRZYPADKU PRZEPELNIEN JAKIEJKOLWIEK TAB- C LICY KOMPILATORA. C NROVFL - NUMER PRZEPELNIENIA (INFORMACJA O TABLICY) C //WYWOLUJE PROCEDURE MERR , BUFORY STRUMIENI PRZESYLA DO C OBSZARU KOMUNIKACYJNEGO W BLOKU //. C USTAWIA FLAGE "DROPOWANIA". C C OPIS W DOKUMENTACJI: B.I.2 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 101 C...................................................................... C IMPLICIT INTEGER (A-Z) C C..... #include "blank3.h" LOGICAL ERRFLG C COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260) C ERRFLG - FLAGA BLEDOW C C SYGNALIZOWANIE BLEDU LINE = 9999 CALL MERR(NROVFL, 0) C DROPFG = .TRUE. C ERRFG = .TRUE. IOP(1) = IOP(1)+7 CALL MESS CALL ML2 RETURN END SUBROUTINE MERR(NRE, ID) C--------------PROCEDURA WPISUJACA SYGNALIZACJE BLEDOW NA STRUMIEN 2 C NRE - NUMER BLEDU C ID - IDENTYFIKACJA BLEDU, TO ZNACZY C -IDENTYFIKATOR ZE SCANNERA, C -ZANEGOWANY ZNAK W PRAWYM BAJCIE, C -ZERO OZNACZAJACE BRAK IDENTYFIKATORA. C //PROCEDURA W RAZIE POTRZEBY NISZCZY DOTYCHCZASOWY C ZAPIS ZNAJDUJACY SIE NA STRUMIENIU SO (KOD DLA ASSEMBLERA) C ORAZ USTAWIA FLAGE BLEDOW ERRFLG. C C OPIS W DOKUMENTACJI: B.I.1 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 146 C................................................................. C IMPLICIT INTEGER (A-Z) C C *CALL STREAM LOGICAL ERRFLG COMMON /STREAM/ ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260) C ERRFLG - FLAGA BLEDOW C !!!!!! END OF SUBSTITUTION OF COMDECK STREAM FROM LOGLAN.14 !! C *CALL MJLMSG COMMON /MJLMSG/ IERC, MSG C !!!!!! END OF SUBSTITUTION OF COMDECK MJLMSG FROM LOGLAN.14 !! cdeb --------------------- added =---------------- common /debug/deb,breakt(500),brnr,maxbr logical deb cdeb --------------------------------------- C C C----- ZBADANIE, CZY JEST TO PIERWSZY SYGNALIZOWANY BLAD IF (ERRFLG) GOTO 100 C..... PRZYPADEK, GDY BLAD JEST SYGNALIZOWANY PO RAZ PIERWSZY ERRFLG = .TRUE. C --- L-CODE WRITTEN DIRECTLY IN THE SIEMENS VERSION C --- IN THE SIEMENS VERSION OF THE COMPILER IBUF2 IS USED ONLY C --- TO LOCATE THERE INFORMATION ABOUT ERRORS. SO NOW IT IS THE C --- PROPER TIME TO OPEN IT cdeb deb = .false. cdeb c --- unit 19 (ibuf2) - do bledow (direct) CALL OPENF(IBUF2,19) C OD TEJ PORY BUFOR ZACZYNA ODPOWIADAC STRUMIENIOWI O DOSTEPIE C BEZPOSREDNIM . JEGO BUDOWA: C SLOWA 1-7 -BUFOR DLA PROCEDUR ZAPISU I ODCZYTU (OPIS STRUMIENIA) C SLOWO 8 -NUMER AKTUALNIE ZAPISYWANEGO BLOKU C SLOWO 9 -INDEKS PIERWSZEJ WOLNEJ POZYCJI BLOKU AKTUALNIE TWORZO- C NEGO C SLOWO 10 -LICZBA TROJEK WPISANYCH DO BLOKU C SLOWA 10-265 -AKTUALNIE TWORZONY BLOK (TROJKI ZAPISYWANE OD SLO- C WA 11) C IBUF2(8) = 0 IBUF2(9) = 11 C C-----WPISANIE SYGNALIZACJI BLEDU 100 IERC = IERC+1 POZ = IBUF2(9) C POZ - AKTUALNA POZYCJA DO WYPELNIENIA C ZAPISANIE NUMERU LINII, NUMERU BLEDU I IDENTYFIKACJI IBUF2(POZ) = LINE IBUF2(POZ+1) = NRE IBUF2(POZ+2) = ID C MODYFIKACJA BUFORA POZ = POZ+3 IBUF2(9) = POZ IF (POZ .LE. 263) RETURN C ..... JESLI BLOK ZOSTAL ZAPELNIONY, ZAPISANIE GO NA DYSK IBUF2(8) = IBUF2(8) + 1 IBUF2(9) = 11 IBUF2(10) = 85 CALL PUT(IBUF2, IBUF2(10)) RETURN END SUBROUTINE MADATR (IDATR, IDPROT, NROVF) C-------------WPROWADZA ATRYBUT O IDENTYFIKATORZE IDATR DO LISTY ATRYBU- C TOW PROTOTYPU IDPROT. W OPISIE ATRYBUTU NADAJE WARTOSC C POLOM DECLPLACE/SL ORAZ NUMERU ATRYBUTU C // NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA C C OPIS W DOKUMENTACJI: B.III.3 C WERSJA Z DNIA: 19.01.82 (MJL) C DLUGOSC KODU: 99 C......................................................................... C IMPLICIT INTEGER (A-Z) C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C IACT = MGETM(2, NROVF) IPMEM(IACT) = IDATR IOST = IPMEM(IDPROT+7) C IOST - OSTATNI ELEMENT LISTY ATRYBUTOW C ..... DOLACZENIE IACT DO LISTY ATRYBUTOW IPMEM(IOST+1) = IACT IPMEM(IDPROT+7) = IACT C ..... NADANIE WARTOSCI SL ORAZ NUMERU ATRYBUTU IOST = IPMEM(IOST) C IOST - OSTATNI ATRYBUT - INDEKS OPISU IPMEM(IDATR-1) = IDPROT IPMEM(IDATR-2) = IPMEM(IOST-2) + 1 RETURN END SUBROUTINE MSETB (IDPROT, NRPREF) C-------------W ZBIORZE PREFIXSET TYPU IDENTYFIKOWANEGO PRZEZ IDPROT C USTAWIA BIT NRPREF NA 1 C C OPIS W DOKUMENTACJI: B.III.4.2 C WERSJA Z DNIA: 19.03.82 (MJL) C DLUGOSC KODU: 87 C....................................................................... C IMPLICIT INTEGER (A-Z) C C *CALL BLANK C..... #include "blank2.h" C C !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14 !! C IF (NRPREF .GT. 47) RETURN K= NRPREF/16 K= IDPROT-3-K C K - INDEKS MODYFIKOWANEGO ELEMENTU PREFIXSET C L= IAND(NRPREF,15) C L - NUMER ZAPALANEGO BITU L= ISHFT(1,L) C IPMEM(K) = IOR ( IPMEM(K), L) RETURN END