sources/pass1/al13.ff

   1 C    Loglan82 Compiler&Interpreter
   2 C     Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3 C     Copyright (C)  1993, 1994 LITA, Pau
   4 C
   5 C     This program is free software; you can redistribute it and/or modify
   6 C     it under the terms of the GNU General Public License as published by
   7 C     the Free Software Foundation; either version 2 of the License, or
   8 C     (at your option) any later version.
   9 C
  10 C     This program is distributed in the hope that it will be useful,
  11 C     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 C     GNU General Public License for more details. File: LICENSE.GNU
  14 C  ===============================================================
  15
  16 *DECK MPARPF
  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
  24 C                   KONTROLA DYNAMICZNA
  25 C         SYGNALIZOWANE BLEDY
  26 C             626 - NIEZGODNOSC RODZAJOW PARAMETROW FORMALNEGO I AKTUAL-
  27 C                   NEGO (FUNKCJA<->PROCEDURA)
  28 C               NIEZGODNE NAGLOWKI
  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
  33 C               INNE
  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
  37 C                   STANDARDOWA
  38 C
  39 C             OPIS W DOKUMENTACJI:         ?3.7.4
  40 C             WERSJA Z DNIA:               19.01.82
  41 C             DLUGOSC KODU:       807
  42 C.............................................................................
  43 C
  44       IMPLICIT INTEGER (A-Z)
  45       LOGICAL  DCONTR,BTEST
  46 C     *CALL BLANKSEM
  47 C.....
  48 #include "blank.h"
  49 C
  50 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
  51 C     *CALL STCON
  52 C......
  53       LOGICAL  UNICLL
  54       COMMON /MCALLS/  CLLREC, UNICLL
  55 C
  56 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
  57 C     *CALL MPI2
  58 C......BLOK KOMUNIKACJI PROCEDUR  MPARPF  ORAZ  MPIO2
  59       LOGICAL  DCLASS, AFORM
  60       COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS,
  61      X              AFORM
  62 C
  63 C     !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14  !!
  64 C
  65       APROT = PAPROT
  66       AID = PAID
  67       AOB = PAOB
  68 C
  69       DCONTR = .TRUE.
  70 C
  71 C       SPRAWDZENIE, CZY BEDZIE KONTROLA STATYCZNA
  72       IF (UNICLL)    RETURN
  73       IF ( IPMEM(CLLREC+7) .EQ. 0)    RETURN
  74       IF (APROT .EQ. NRUNIV)    RETURN
  75 C
  76 C------ KONTROLA ZGODNOSCI RODZAJOW
  77 C         PF - OPIS PARAMETRU FORMALNEGO
  78       PF = IPMEM(CLLREC+5)
  79       PF = IPMEM(PF)
  80       ZW = IPMEM(APROT)
  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
  84 C
  85 C------ TO NIE JEST ANI FUNKCJA, ANI PROCEDURA
  86   100 CALL  MERR(632, AID)
  87       RETURN
  88 C
  89 C...... PARAMETR AKTUALNY JEST FUNKCJA
  90   200 PALGTH = -1
  91 C         PALGTH - BEDZIE DLUGOSCIA LISTY PF DLA PROTOTYPU AKTUALNEGO
  92       IF (IPMEM(CLLREC+7) .EQ. 4)    GOTO  1000
  93       GOTO  900
  94 C
  95 C...... PARAMETR AKTUALNY JEST PROCEDURA
  96   300 PALGTH = 0
  97       IF (IPMEM(CLLREC+7) .EQ. 5)    GOTO  2000
  98 C
  99 C------ NIEZGODNOSC RODZAJOW
 100   900 CALL  MERR(626, AID)
 101       GOTO  2000
 102 C
 103 C
 104 C***** PARAMETRY SA FUNKCJAMI
 105  1000 CONTINUE
 106 C--- ZBADANIE, CZY PF NIE JEST FUNKCJA DRUGIEGO RZEDU JESLI TAK
 107 C     TO KONIECZNA JEST KONTROLA DYNAMICZNA
 108       DCONTR = .TRUE.
 109       IF (IPMEM(CLLREC+2) .EQ. 2)    RETURN
 110       DCONTR = .FALSE.
 111 C--- ZBADANIE ZGODNOSCI TYPOW FUNKCJI FORMALNEJ I AKTUALNEJ
 112       CALL  MFUNEQ (APROT, AID, AOB, PF, DCONTR)
 113       GOTO  3000
 114 C
 115 C***** PARAMETRY SA PROCEDURAMI
 116  2000 DCONTR = .TRUE.
 117       IF (IPMEM(CLLREC+2) .EQ. 2)    RETURN
 118       DCONTR = .FALSE.
 119 C
 120 C
 121 C*************************************************************************
 122 C         WSPOLNA DLA FUNKCJI I PROCEDUR KONTROLA ZGODNOSCI LIST
 123 C
 124  3000 CONTINUE
 125       IF (APROT .GT. LPMSYS)    GOTO  3010
 126 C       --UZYTY MODUL STANDARDOWY
 127         CALL  MERR(635, AID)
 128 C       TWORZONY JEST MALY REKORD ZAMIANY TYPOW (W CZESCI PRZEZNACZONEJ
 129 C       NA PROTOTYPY UZYTKOWNIKA
 130  3010 OLPMF = LPMF
 131       DCONTR = .FALSE.
 132       AFORM = .FALSE.
 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
 137       PFEL = IPMEM(PF+3)
 138 C         ELEMENT LISTY PF FUN/PROC FORMALNEJ
 139       PFLGTH = IPMEM(PF+4)
 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)
 144 C
 145 C*************
 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
 151 C
 152  4000 PFPF = IPMEM(PFEL)
 153       PFPA = IPMEM(PAEL)
 154 C         -PFPF - PARAMETR FORMALNY FUN/PROC FORMALNEJ
 155 C         -PFPA - PARAMETR FORMALNY FUN/PROC AKTUALNEJ
 156       KINDPF = IPMEM(PFPF)
 157       KINDPF = IAND (ISHFT(KINDPF, -4), 15) + 1
 158       KINDPA = IPMEM(PFPA)
 159       KINDPA = IAND(ISHFT(KINDPA, -4), 15) + 1
 160       GOTO (5000, 4100, 4200, 4200, 5000, 4300, 4300, 5000,
 161      X      5000, 4300), KINDPF
 162 C
 163 C......PFPF JEST TYPEM FORMALNYM
 164 C       PFPA TEZ MUSI BYC TYPEM FORMALNYM (LUB PARAMETREM
 165 C       UNIWERSALNYM)
 166 C       WSTAWIENIE PARY DO MALEGO REKORDU
 167  4100 KINDPF = MGETM(2,0)
 168       IPMEM(KINDPF) = PFPF
 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
 174         GOTO  4900
 175 C
 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
 180         GOTO  4900
 181 C
 182 C......PFPF JEST PARAMETREM INPUT/OUTPUT/INOUT
 183 C         WYWOLANIE PROCEDURY KONTROLUJACEJ ZGODNOSC TYPOW
 184  4300 IF (KINDPA .LE. 5 )    GOTO  4900
 185       CALL  MPIO2 (DCONTR)
 186       IF (KINDPF .EQ. KINDPA)    GOTO  5000
 187 C
 188 C......NIEZGODNE RODZAJE PFPF I PFPA
 189  4900 CALL  MERR(627, AID)
 190 C*****PRZESUNIECIE LIST PARAMETROW
 191  5000 PFEL = PFEL + 1
 192       PAEL = PAEL + 1
 193       PFLGTH = PFLGTH - 1
 194       PALGTH = PALGTH - 1
 195       IF ( (PFLGTH .NE. 0) .AND. (PALGTH .NE. 0) )    GOTO  4000
 196 C***************************************
 197 C
 198 C******************
 199 C-------ZBADANIE ZGODNOSCI DLUGOSCI LIST PF
 200 C         ZNISZCZENIE MALEGO REKORDU
 201  6000 LPMF = OLPMF
 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
 205 C       SYGNALIZACJI BLEDU
 206 C       ZW - POLE S PROTOTYPU APROT
 207       IF ( (ZW .EQ. 4) .OR. (ZW .EQ. 6))    RETURN
 208       GOTO  6200
 209 C       TU: LISTA PF JEST KROTSZA, TA POWINNA BYC USZKODZONA BY NIE BYLO
 210 C       SYGNALIZACJI BLEDU
 211  6100 ZW = IPMEM(PF)
 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)
 216       RETURN
 217 C     ---LISTY ROWNYCH DLUGOSCI, SYGNALIZACJA BLEDOW GDY (TYLKO) JEDNA Z NICH
 218 C        JEST USZKODZONA
 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
 222       ZW = IPMEM(PF)
 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
 226       RETURN
 227       END
 228 *DECK MFUNEQ
 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
 237 C                    FUNKCJI FORMALNEJ
 238 C             OPIS W DOKUMENTACJI:          ?3.7.2
 239 C             WERSJA Z DNIA:                19.01.82
 240 C             DLUGOSC KODU:        663
 241 C.............................................................................
 242 C
 243       IMPLICIT INTEGER (A-Z)
 244       LOGICAL DCONTR
 245 C
 246 C     *CALL BLANKSEM
 247 C.....
 248 #include "blank.h"
 249 C
 250 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
 251 C     *CALL STCON
 252 C......
 253       LOGICAL  UNICLL
 254       COMMON /MCALLS/  CLLREC, UNICLL
 255 C
 256 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
 257 C     *CALL MTPC
 258 C......BLOK KOMUNIKACJI Z PROCEDURA  MTPCON
 259       COMMON /MTPC/ PRFXR, PRFXL
 260 C
 261 C     !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14  !!
 262 C
 263 C.....POBRANIE TYPU FUNKCJI AKTUALNEJ
 264       TRDIM = IPMEM(PA-4)
 265       TRBAS = IPMEM(PA-3)
 266 C.....POBRANIE TYPU FUNKCJI FORMALNEJ
 267       TLDIM = IPMEM(PF-4)
 268       TLBAS = IPMEM(PF-3)
 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
 277 C*******************
 278 C     TYPY NIETABLICOWE
 279 C
 280 C.....ROZPOZNANIE PRZYPADKU TYPOW PIERWOTNYCH
 281       IF (AZW .GE. 8)    GOTO  100
 282       IF (FZW .GE. 8)    GOTO  200
 283         GOTO  1000
 284 C       --SKOK, GDY ZADEN TYP NIE JEST PIERWOTNY
 285 C*****TYPY PIERWOTNE
 286 C.....TRBAS (FUNKCJA AKTUALNA) JEST PIERWOTNY
 287   100 IF (TLBAS .EQ. NRUNIV)    RETURN
 288       IF (TLBAS .EQ. TRBAS)    RETURN
 289         GOTO  9100
 290 C       --SKOK GDY TYPY SA NIEZGODNE
 291 C.....TLBAS (FUNKCJA FORMALNA) JEST PIERWOTNY
 292   200 IF (TRBAS .EQ. NRUNIV)    RETURN
 293 C       GOTO  9100
 294 C
 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 -
 301 C       SYGNALIZACJA BLEDU
 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
 307 C        JEST WIRTUALNY
 308       IF (IPMEM(CLLREC+2) .NE. 2)    DCONTR = .TRUE.
 309       RETURN
 310 C
 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
 314 C        DYNAMICZNA
 315       DCONTR = .TRUE.
 316       RETURN
 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
 322       PRFXR = AOB
 323       PRFXL = OBJL
 324       IF (MTPCON(Z) .EQ. 1)    RETURN
 325 C     ...POTRZEBNA KONTROLA DYNAMICZNA
 326  1250 DCONTR = .TRUE.
 327       RETURN
 328 C
 329 C
 330 C********************
 331 C     TYPY ZLOZONE TABLICOWE (CO NAJMNIEJ JEDEN)
 332  2000 IF (TLDIM-TRDIM)    2100, 2200, 2300
 333 C
 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
 341       DCONTR = .TRUE.
 342       PRFXR = AOB
 343       PRFXL = OBJL
 344       IF (MTPCON(Z) .NE. 1)    RETURN
 345       IF (IPMEM(CLLREC+2) .NE. 0)    RETURN
 346       GOTO  9100
 347 C
 348 C.....TLDIM=TRDIM
 349 C     POPRAWNE GDY
 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
 358       GOTO  9100
 359 C
 360  2250 PRFXR = AOB
 361       PRFXL = OBJL
 362       IF (MTPCON(Z) .NE. 1)    DCONTR = .TRUE.
 363       IF (IPMEM (CLLREC+2) .EQ. 1)    DCONTR = .TRUE.
 364       RETURN
 365 C
 366 C.....TLDIM>TRDIM
 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
 373       DCONTR = .TRUE.
 374       PRFXR = AOB
 375       PRFXL = OBJL
 376       IF (MTPCON(Z) .NE. 1)    RETURN
 377       IF (IPMEM(CLLREC+2) .NE. 0)    RETURN
 378       GOTO  9100
 379 C
 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) ) )
 386      X                            GOTO  9200
 387 C
 388 C.....TYPY NIEZGODNE
 389  9100 CALL  MERR(631, AID)
 390       RETURN
 391 C.....TYP FUNKCJI AKTUALNEJ JEST SLABIEJ OKRESLONY
 392  9200 CALL  MERR(633, AID)
 393       RETURN
 394       END
 395 *DECK MPIO2
 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
 412 C
 413 C             OPIS W DOKUMENTACJI:         ?3.7.3.5
 414 C             WERSJA Z DNIA:               19.01.82
 415 C             DLUGOSC KODU:        974
 416 C.............................................................................
 417 C
 418       IMPLICIT INTEGER (A-Z)
 419       LOGICAL DCONTR,BTEST
 420 C
 421 C     *CALL BLANKSEM
 422 C.....
 423 #include "blank.h"
 424 C
 425 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
 426 C     *CALL STCON
 427 C......
 428       LOGICAL  UNICLL
 429       COMMON /MCALLS/  CLLREC, UNICLL
 430 C
 431 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
 432 C     *CALL MTPC
 433 C......BLOK KOMUNIKACJI Z PROCEDURA  MTPCON
 434       COMMON /MTPC/ PRFXR, PRFXL
 435 C
 436 C     !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14  !!
 437 C     *CALL MPI2
 438 C......BLOK KOMUNIKACJI PROCEDUR  MPARPF  ORAZ  MPIO2
 439       LOGICAL  DCLASS, AFORM
 440       COMMON /MPI2/ PFPF, PFPA, PF, APROT, AID, AOB, OLPMF, DCLASS,
 441      X              AFORM
 442 C
 443 C     !!!!!! END OF SUBSTITUTION OF COMDECK MPI2 FROM LOGLAN.14  !!
 444 C
 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
 453 C     LUB APROT
 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
 459       IF (AFORM)    GOTO  2000
 460       IF (MPRFSQ(IPMEM(TRBAS-1), APROT) .EQ. 1)    GOTO  1000
 461 C       --SKOK GDY TYP W MODULE AKTUALNYM JEST WLASNYM PARAMETREM MODULU
 462       GOTO  2000
 463 C
 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
 469       GOTO  9100
 470  1100 IF (TRBAS .NE. NRUNIV)    GOTO  1200
 471       IF (TLDIM .GE. TRDIM)    RETURN
 472       GOTO  9100
 473 C.....ZADEN TYP NIE JEST UNIWERSALNY, OBYDWA POWINNY BYC WLASNE I SOBIE
 474 C     ODPOWIADAJACE
 475  1200 IF (AZW .NE. 6)    GOTO  9100
 476       IF (IPMEM(TRBAS-1) .EQ.  APROT)    GOTO  1300
 477       IF (AFORM)    GOTO  9100
 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
 483       AZW = LPMF+1
 484  1300 IF (IPMEM(AZW) .EQ. TLBAS)    GOTO  1400
 485         AZW = AZW+2
 486         GOTO  1300
 487  1400 TLBAS = IPMEM(AZW+1)
 488       IF (TLBAS .EQ. TRBAS)    RETURN
 489       GOTO  9100
 490 C
 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
 497 C
 498 C*********************
 499 C     TYPY NIETABLICOWE
 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
 514 C         SYGNALIZACJI BLEDU
 515       IF (DCLASS)    DCONTR = .TRUE.
 516       IF (IPMEM(CLLREC+2) .NE. 0)    DCONTR = .TRUE.
 517       RETURN
 518 C           DODATKOWA KONTROLA JEST POTRZEBNA GDY MODUL AKTUALNY NIE JEST
 519 C           RZECZYWISTY
 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
 524       RETURN
 525 C
 526 C     **CO NAJMNIEJ JEDEN TYP JEST PRYMITYWNY, DRUGI POWINIEN BYC MU ROWNY
 527  2200 IF(TLBAS .EQ. TRBAS)    RETURN
 528       GOTO  9100
 529 C
 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
 534  2350 DCONTR = .TRUE.
 535       RETURN
 536 C     ...OBYDWA TYPY SA FORMALNE
 537 C       KONTROLA DYNAMICZNA JEST ZAWSZE KONIECZNA, GDY WYWOLYWANY MODUL JEST
 538 C       WIRTUALEM
 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
 542       PRFXR = AOB
 543       PRFXL = OBJL
 544       IF (MTPCON(Z) .EQ. 1)    RETURN
 545       DCONTR = .TRUE.
 546       RETURN
 547 C
 548 C
 549 C****************************************
 550 C     TYPY TABLICOWE
 551  3000 IF (TLDIM - TRDIM)    3100, 3200, 3300
 552 C
 553 C.....TLDIM<TRDIM
 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
 561       PRFXR = AOB
 562       PRFXL = OBJL
 563       IF (MTPCON(Z) .EQ. 1)    GOTO  9100
 564  3150 DCONTR = .TRUE.
 565       RETURN
 566 C
 567 C.....TLDIM=TRDIM
 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
 578       GOTO  9100
 579 C     ...TYP TLBAS JEST FORMALNY
 580  3210 IF (AZW .EQ. 6)    GOTO  3230
 581  3220 DCONTR = .TRUE.
 582       RETURN
 583 C     ...OBYDWA TYPY SA FORMALNE
 584  3230 IF (IPMEM(CLLREC+2) .NE. 0)    GOTO  3220
 585       IF (BTEST(IPMEM(APROT), 11))    GOTO  3220
 586       PRFXR = AOB
 587       PRFXL = OBJL
 588       IF (MTPCON (Z) .NE. 1)    GOTO  3220
 589       RETURN
 590 C
 591 C.....TLDIM>TRDIMCPOPRAWNE JEDYNIE, GDY OBYDWA TYPY SA FORMALNE LUB
 592 C     UNIWERSALNE
 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
 598       DCONTR = .TRUE.
 599       PRFXR = AOB
 600       PRFXL = OBJL
 601       IF (MTPCON(Z) .NE. 1)    RETURN
 602       IF (IPMEM(CLLREC+2) .NE. 0)    RETURN
 603       IF (BTEST(IPMEM(APROT), 11))    RETURN
 604       GOTO  9100
 605 C
 606 C***************************************
 607 C     SYGNALIZACJE BLEDOW
 608  9100 CALL  MERR(628, AID)
 609       RETURN
 610 C     BADANIE OKRESLONOSCI TYPOW
 611  9200 IF ( (TLBAS .NE. NRCOR) .AND.
 612      X     ( (TRBAS .EQ. NRCOR) .OR. (TRBAS .EQ. NRPROC)))    GOTO  9300
 613       CALL  MERR (629, AID)
 614       RETURN
 615  9300 CALL  MERR(634, AID)
 616       RETURN
 617       END
 618 *DECK MPARIO
 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
 623 C                  ZMIENNEJ, FUNKCJI)
 624 C             AOB - OBIEKT W CIAGU SL, Z KTOREGO BRANY JEST PARAMETR
 625 C                  AKTUALNY, LUB 0 - GDY NIE JEST DOSTEPNY PRZEZ
 626 C                   DISPLAY
 627 C             / WARTOSC FUNKCJI INFORMUJE O KONWERSJI LUB KONTROLI
 628 C               DYNAMICZNEJ - TAK JAK W  MSUBST.
 629 C               ODPOWIEDNIOSC JEST NASTEPUJACA:
 630 C                 - PARAMETR INPUT
 631 C                     LEWA STRONA - PARAMETR FORMALNY
 632 C                     PRAWA STRONA - PARAMETR AKTUALNY
 633 C                 - PARAMETR OUTPUT
 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
 643 C
 644 C         SYGNALIZOWANE BLEDY
 645 C             Z PROCEDURY  MSUBST
 646 C             609 - NIEZGODNE TYPY
 647 C             610 - ROZLACZNE SEKWENCJE PREFIKSOWE
 648 C
 649 C             OPIS W DOKUMENTACJI:          ?3.6.2
 650 C             WERSJA Z DNIA:                19.01.82
 651 C             DLUGOSC KODU:        519
 652 C.............................................................................
 653 C
 654       IMPLICIT INTEGER (A-Z)
 655       LOGICAL  FNFORM
 656 C        FNFORM MA WARTOSC .TRUE. GDY PARAMETR FORMALNY NIE JEST
 657 C        TYPU FORMALNEGO
 658 C     *CALL BLANKSEM
 659 C.....
 660 #include "blank.h"
 661 C
 662 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
 663 C     *CALL STCON
 664 C......
 665       LOGICAL  UNICLL
 666       COMMON /MCALLS/  CLLREC, UNICLL
 667 C
 668 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
 669 C
 670 C
 671       FNFORM = .TRUE.
 672       MPARIO = 0
 673 C...... KONTROLA WYWOLANIA UNIWERSALNEGO
 674       IF (UNICLL)    RETURN
 675       IF (IPMEM(CLLREC+7) .EQ. 0)    RETURN
 676 C
 677 C------POBRANIE TYPU PARAMETRU FORMALNEGO
 678       PF = IPMEM(CLLREC+5)
 679       PF = IPMEM(PF)
 680 C         ... PF OPIS PARAMETRU FORMALNEGO
 681       FDIM = IPMEM(PF-4)
 682       FBAS = IPMEM(PF-3)
 683 C         ...FDIM, FBAS - NIEZMODYFIKOWANY TYP PARAMETRU FORM.
 684 C
 685       FOB = IPMEM(CLLREC+3)
 686 C         PARAMETR FORMALNY "POCHODZI" Z TEGO SAMEGO OBIEKTU, CO OBIEKT
 687 C         WYWOLYWANY
 688 C
 689 C------BADANIE RODZAJU OBIEKTU WYWOLYWANEGO
 690 C
 691       IF (IPMEM(CLLREC+2) .NE. 0)    GOTO  1000
 692 C
 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
 701       TLDIM = FDIM
 702       TLBAS = FBAS
 703       OBJL = FOB
 704       IDL = ID
 705       TRDIM = ATDIM
 706       TRBAS = ATBASE
 707       IDR = ID
 708       OBJR = AOB
 709 C
 710       MPARIO = MSUBST (Z)
 711 C          Z - SLEPY PARAMETR
 712       IF (FNFORM)    RETURN
 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 =
 716      X                                 MPARIO + 1
 717       RETURN
 718 C     ---KONTROLA 'INOUT' - JAK OUTPUT PRZY PIERWSZYM WYWOLANIU, INPUT PRZY
 719 C        DRUGIM
 720    95 IPMEM(CLLREC+7) = -6
 721 C     --- KONTROLA PARAMETRU OUTPUT
 722   100 TLDIM = ATDIM
 723       TLBAS = ATBASE
 724       IDL = ID
 725       OBJL = AOB
 726       TRBAS = FBAS
 727       TRDIM = FDIM
 728       IDR = ID
 729       OBJR = FOB
 730 C
 731       MPARIO = MSUBST(Z)
 732       IF (FNFORM)    RETURN
 733   110 IF ( (MPARIO .EQ. 3) .OR. (MPARIO .EQ. 4) )    MPARIO =
 734      X                                  MPARIO + 2
 735       RETURN
 736 C
 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
 746       TLDIM = FDIM
 747       TLBAS = FBAS
 748       IDL = ID
 749       OBJL = FOB
 750       TRDIM = ATDIM
 751       TRBAS = ATBASE
 752       IDR = ID
 753       OBJR = AOB
 754 C
 755       MPARIO = MSUBST (Z)
 756       IF (FNFORM)    GOTO  1200
 757       GOTO  90
 758 C     --- KONTROLA PARAMETRU OUTPUT
 759  1100 TLDIM = ATDIM
 760       TLBAS = ATBASE
 761       IDL = ID
 762       OBJL = AOB
 763       TRDIM = FDIM
 764       TRBAS = FBAS
 765       IDR = ID
 766       OBJR = FOB
 767 C
 768       MPARIO = MSUBST (Z)
 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
 775       PF = IPMEM(PF-3)
 776 C     ..PF - OPIS TYPU PARAMETRU
 777       PF = IAND (IPMEM(PF), 15)
 778       IF (PF .GE. 8)    RETURN
 779       MPARIO = 3
 780       RETURN
 781       END
 782 *DECK MSUBST
 783       INTEGER FUNCTION  MSUBST (X)
 784 C                X - SLEPY PARAMETR
 785 C
 786 C-------------PROCEDURA BADA POPRAWNOSC INSTRUKCJI PODSTAWIENIA.
 787 C             JEST ROWNIEZ WYWOLYWANA W PROCEDURZE KONTROLI
 788 C             TYPOW PARAMETROW FORMALNYCH I AKTUALNYCH.
 789 C             ZNACZENIE  :
 790 C              - TLDIM, TLBAS - TYP LEWEJ STRONY INSTRUKCJI PODSTAWIENIA,
 791 C                OBJL - PROTOTYP, Z KTOREGO POCHODZI, LUB 0 - NIEDOSTEPNA
 792 C                PRZEZ DISPLAY
 793 C                IDL - IDENTYFIKATOR LEWEJ STRONY (DO SYGNALIZACJI
 794 C                BLEDOW),
 795 C              - ANALOGICZNIE DLA PRAWEJ STRONY - TRDIM, TRBAS,
 796 C                OBJR .
 797 C             // WARTOSC FUNKCJI OKRESLA RODZAJ KONWERSJI LUB KONTROLI
 798 C                DYNAMICZNEJ :
 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-
 810 C                   KSOWE
 811 C             636 - NIEDOZWOLONE UZYCIE SEMAFORA
 812 C
 813 C             OPIS W DOKUMENTACJI:          ?2.7
 814 C             WERSJA Z DNIA:                19.01.82
 815 C             DLUGOSC KODU:         617
 816 C.............................................................................
 817 C
 818       IMPLICIT INTEGER (A-Z)
 819 C
 820 C     *CALL BLANKSEM
 821 C.....
 822 #include "blank.h"
 823 C
 824 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
 825 C     *CALL MTPC
 826 C......BLOK KOMUNIKACJI Z PROCEDURA  MTPCON
 827       COMMON /MTPC/ PRFXR, PRFXL
 828 C
 829 C     !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14  !!
 830 C
 831 C       INICJOWANA WARTOSC MSUBST - 3 ODPOWIADAJACA KONTROLI DYNAMICZNEJ
 832       MSUBST = 3
 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
 836 C
 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
 843 C
 844       GOTO (9000, 100, 100, 9500, 100, 200, 100, 300, 9100, 400, 500,
 845      X      400, 9000, 9000), TPL
 846 C
 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
 857           CALL  MERR(610, IDL)
 858           RETURN
 859 C
 860 C         TPL JEST PREFIKSEM TPR - KONTROLA DYNAMICZNA NIE JEST
 861 C         POTRZEBNA, TPR MOZE BYC ROWNIEZ  NONE
 862   130     MSUBST = 0
 863           RETURN
 864 C
 865 C         TPR JEST PREFIKSEM TPL - KONTROLA DYNAMICZNA JEST POTRZEBNA
 866 C         KONTEKSTOWO SYTUACJA JEST POPRAWNA
 867   140     RETURN
 868 C     ... TPR JEST FORMALNY
 869   150     MSUBST = 5
 870           RETURN
 871 C
 872 C
 873 C...... TPL JEST TYPEM FORMALNYM - TPR MUSI BYC TYPEM FORMALNYM, KLASO-
 874 C       WYM, SYSTEMOWYM LUB  NONE
 875   200   MSUBST = 4
 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
 879   210     RETURN
 880 C     ... TPR - FORMALNY
 881   220     MSUBST = 6
 882       PRFXR = OBJR
 883       PRFXL = OBJL
 884       IF ( MTPCON(Z) .EQ. 1)    MSUBST = 0
 885           RETURN
 886 C
 887 C
 888 C...... TPL JEST ARYTMETYCZNY, TPR TEZ MUSI BYC ARYTMETYCZNY
 889   300   IF ( (TRBAS .NE. NRINT) .AND. (TRBAS .NE. NRRE) )    GOTO  9000
 890         MSUBST = 0
 891         IF (TLBAS .EQ. TRBAS) RETURN
 892 C         TU - TYPY ROZNE - POTRZEBNA KONWERSJA
 893           MSUBST = 2
 894           IF (TLBAS .EQ. NRINT)    MSUBST = 1
 895           RETURN
 896 C
 897 C...... TPL - INNY PRYMITYWNY, TPR MUSI BYC MU ROWNE
 898   400   MSUBST = 0
 899         IF (TLBAS .EQ. TRBAS)    RETURN
 900         GOTO  9000
 901 C.......TPL - FILE, TPR MUSI BYC FILE LUB NONE
 902   500   MSUBST = 0
 903         IF ((TLBAS .EQ. TRBAS) .OR. (TRBAS .EQ. NRNONE)) RETURN
 904         GOTO 9000
 905 C
 906 C
 907 C------ CO NAJMNIEJ JEDEN TYP JEST TABLICOWY
 908 C
 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
 918         MSUBST = 4
 919         IF (TPR .EQ. 6)    MSUBST = 6
 920         GOTO  8000
 921 C
 922 C......PRZYPADEK  TLDIM = TRDIM
 923 C       POPRAWNE, GDY
 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
 928 C
 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
 934         MSUBST = 0
 935         IF (TLBAS .EQ. TRBAS)    RETURN
 936 C         TU - NIEROWNE TYPY NIEFORMALNE - SKOK DO SYGNALIZACJI BLEDOW
 937         GOTO  9000
 938 C
 939 C     ... TLBAS JEST FORMALNY, TRBAS NIE
 940  3100   MSUBST = 4
 941         RETURN
 942 C     ... TRBAS JEST FORMALNY, TLBAS NIE
 943  3200   MSUBST = 5
 944         RETURN
 945 C     ... TLBAS I TRBAS SA FORMALNE, SPRAWDZENIE,CZY SA ROWNE I LOKALNE
 946 C         (WTEDY NIE MA KONTROLI DYNAMICZNEJ)
 947  3300     MSUBST = 6
 948       PRFXR = OBJR
 949       PRFXL = OBJL
 950       IF ( MTPCON(Z) .EQ. 1)    MSUBST = 0
 951          RETURN
 952 C
 953 C...... PRZYPADEK  TLDIM > TRDIM
 954 C         POPRAWNE,GDY:
 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
 959  4000   MSUBST = 0
 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
 966         MSUBST = 5
 967         IF (TPL .EQ. 6)    MSUBST = 6
 968 C       GOTO  8000 - PRZEJSCIE DO BADANIA TYPOW TABLICOWYCH
 969 C
 970 C
 971 C------ BADANIE ZGODNOSCI FORMALNYCH TYPOW TABLICOWYCH
 972 C
 973  8000 PRFXR = OBJR
 974       PRFXL = OBJL
 975       IF ( MTPCON(Z) .EQ. 1)    GOTO  9000
 976       RETURN
 977 C
 978 C
 979 C
 980 C------SYGNALZACJA BLEDOW
 981  9000 IF (TPR .EQ. 9)    GOTO  9100
 982       CALL  MERR(609, IDL)
 983  9500 RETURN
 984  9100 IF (TPL .EQ. 9)    CALL  MERR(636, IDL)
 985       IF (TPR .EQ. 9)    CALL  MERR(636, IDR)
 986       RETURN
 987       END
 988 *DECK MEQUAL
 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
 998 C               DISPLAY.
 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-
1015 C                   DNE
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
1020 C
1021 C             OPIS W DOKUMENTACJI:          ?2.6
1022 C             WERSJA Z DNIA:                13.05.83 (FRIDAY)
1023 C             DLUGOSC KODU:        664
1024 C.............................................................................
1025 C
1026       IMPLICIT INTEGER (A-Z)
1027 C
1028 C     *CALL BLANKSEM
1029 C.....
1030 #include "blank.h"
1031 C
1032 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1033 C     *CALL MTPC
1034 C......BLOK KOMUNIKACJI Z PROCEDURA  MTPCON
1035       COMMON /MTPC/ PRFXR, PRFXL
1036 C
1037 C     !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14  !!
1038 C
1039       CONVL = 0
1040       CONVR = 0
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
1046 C
1047       GOTO (9000, 100, 100, 200, 100, 300, 100, 400, 9100, 500,
1048      X     800, 700, 9000, 300), TPL
1049 C
1050 C-----TPL JEST TYPEM KLASOWYM LUB SYSTEMOWYM
1051   100 CASE = 5
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
1061           CALL  MERR(607, IDL)
1062           RETURN
1063 C
1064 C....... TPR JEST TYPEM UNIWERSALNYM LUB TYPEM  NONE
1065   120 RETURN
1066 C
1067 C....... TPR JEST TYPEM FORMALNYM
1068   130 CASE = 6
1069       RETURN
1070 C
1071 C
1072 C----- TPL JEST TYPEM UNIWERSALNYM, WTEDY POROWNANIE JEST ZAWSZE
1073 C       POPRAWNE - O ILE TPR NIE JEST TYPEM TEKSTOWYM
1074   200 CASE = 5
1075       IF (TRBAS .EQ. NRTEXT)    GOTO  700
1076       RETURN
1077 C
1078 C----- TPL  JEST TYPEM FORMALNYM LUB TYPEM NONE - BY ZACHODZILA ZGODNOSC
1079 C     TO  TPR  MUSI BYC TYPEM FORMALNYM, KLASOWYM, SYSTEMOWYM, UNIWER-
1080 C     SALNYM LUB NONE
1081   300 CASE = 6
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
1089         GOTO  9000
1090 C
1091 C----- TPL JEST TYPEM ARYTMETYCZNYM, WTEDY TPR TEZ MUSI BYC ARYTMETYCZNE
1092 C       (LUB UNIWERSALNE)
1093   400 IF ((TRBAS .NE. NRINT) .AND.
1094      X    (TRBAS .NE. NRRE) .AND.
1095      X     (TRBAS .NE. NRUNIV))    GOTO  9000
1096       CASE = 2
1097 cdsw      IF ((TPR .EQ.TPL) .AND. (TRBAS .EQ.NRINT)) CASE = 1
1098       IF ((trbas .EQ. tlbas) .AND. (TRBAS .EQ. NRINT) ) CASE = 1
1099       CONVL = 0
1100       CONVR = 0
1101       IF (CASE .EQ. 1)    RETURN
1102       IF (TLBAS .EQ. NRINT)    CONVL = 1
1103       IF (TRBAS .EQ. NRINT)    CONVR = 1
1104       RETURN
1105 C
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
1109       CASE = 3
1110       IF ((TRBAS .EQ. NRBOOL) .OR. (TRBAS .EQ. NRUNIV))    RETURN
1111       GOTO  9000
1112 C
1113 C-----TPL  JEST TYPEM  CHAR, WTEDY  TPR MUSI BYC BADZ  CHAR BADZ UNIWER-
1114 C     SALNY
1115   600 CASE = 4
1116       IF ((TRBAS .EQ. NRCHR) .OR. (TRBAS .EQ. NRUNIV))    RETURN
1117          GOTO  9000
1118 C
1119 C-----TPL JEST TYPEM TEKSTOWYM, NIEZALEZNIE OD TPR JEST TO BLAD
1120   700 CASE = 5
1121       CALL  MERR(608, IDL)
1122       IF (TRBAS .EQ. NRTEXT)    CALL  MERR(608, IDR)
1123       RETURN
1124 C
1125 C-----TPL - FILE. TPR MUSI BYC FILE LUB UNIWERSALNY LUB NONE
1126  800  CASE = 5
1127       IF ((TPR .EQ. 11) .OR. (TRBAS .EQ. NRUNIV)
1128      X     .OR. (TRBAS .EQ. NRNONE))  RETURN
1129       GOTO 9000
1130 C
1131 C
1132 C----- POROWNYWANIE TYPOW TABLICOWYCH
1133  1000 CASE = 5
1134       IF (TLDIM-TRDIM)  2000, 3000, 4000
1135 C...... PRZYPADEK  TLDIM < TRDIM
1136 C       WOWCZAS POPRAWNE JEDYNIE, GDY TLBAS JEST FORMALNY, UNIWERSALNY
1137 C       LUB NONE
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
1143       GOTO  8500
1144 C
1145 C...... PRZYPADEK  TLDIM = TRDIM
1146 C       POPRAWNE, GDY :
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
1153         GOTO  9000
1154 C
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
1160       GOTO  8500
1161 C
1162 C
1163 C------ USTALENIE RODZAJU ZGODNOSCI TYPOW REFERENCYJNYCH, GDY CO
1164 C       NAJMNIEJ JEDEN Z NICH JEST TYPEM FORMALNYM
1165 C
1166  8000 CASE = 6
1167       PRFXR = OBJR
1168       PRFXL = OBJL
1169       IF ( MTPCON(Z) )    8200, 8200, 8100
1170 C           MTPCON PRZYJMUJE NASTEPUJACE WARTOSCI
1171 C             -1 - TYP TEN SAM Z ROZNYCH OBIEKTOW
1172 C              0 - TYPY ROZNE
1173 C             +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU
1174 C
1175  8100 CASE = 5
1176  8200 RETURN
1177 C
1178 C...... UZTALENIE ZGODNOSCI TYPOW TABLICOWYCH - JEDEN Z NICH
1179 C       JEST FORMALNY
1180 C
1181  8500 CASE = 6
1182       PRFXR = OBJR
1183       PRFXL = OBJL
1184       IF ( MTPCON(Z) .NE. 1)    RETURN
1185 C             WPP - SYGNALIZACJA BLEDOW - NIE MA PODSTAWIENIA UNIFIKU-
1186 C                   JACEGO
1187 C
1188 C
1189 C
1190 C------ SYGNALIZOWANIE BLEDOW
1191  9000 CASE = 5
1192       IF (TPR .EQ. 9)    GOTO  9100
1193       IF ((TRDIM .EQ. 0) .AND. (TRBAS .EQ. NRTEXT))    CALL  MERR(608,
1194      X                                             IDR)
1195       CALL  MERR(606, IDL)
1196       RETURN
1197 C --- SYGNALIZACJA BLEDOW - NIEDOZWOLONE UZYCIE SEMAFORA
1198  9100 CASE = 5
1199       IF (TPL .EQ. 9)    CALL  MERR(636, IDL)
1200       IF (TPR .EQ. 9)    CALL  MERR(636, IDR)
1201       RETURN
1202       END
1203 *DECK MPKIND
1204       INTEGER FUNCTION  MPKIND (ATTRAD)
1205 C-------------FUNKCJA OKRESLAJACA RODZAJ KOLEJNEGO PARAMETRU
1206 C             FORMALNEGO
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-
1211 C               NYCH (0,1,2,...)
1212 C             / WARTOSC FUNKCJI OKRESLA RODZAJ PARAMETRU FORMALNEGO
1213 C                0 - UNIWERSALNY
1214 C                1 - INPUT
1215 C                2 - OUTPUT
1216 C                3 - TYP
1217 C                4 - FUNKCJA
1218 C                5 - PROCEDURA
1219 C             // FUNKCJA KORZYSTA Z PROCEDURY  MNOPF
1220 C         SYGNALIZOWANY BLAD
1221 C             622 (Z MNOPF) - ZA KROTKA LISTA PF
1222 C
1223 C             OPIS W DOKUMENTACJI:           ?3.4.3.2
1224 C             WERSJA Z DNIA:                 19.01.82
1225 C             DLUGOSC KODU:         141
1226 C.............................................................................
1227 C
1228       IMPLICIT INTEGER (A-Z)
1229       LOGICAL  MNOPF
1230 C     *CALL BLANKSEM
1231 C.....
1232 #include "blank.h"
1233 C
1234 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1235 C     *CALL STCON
1236 C......
1237       LOGICAL  UNICLL
1238       COMMON /MCALLS/  CLLREC, UNICLL
1239 C
1240 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
1241 C
1242 C
1243       MPKIND = 0
1244       ATTRAD = NRUNIV
1245       IF (MNOPF(0))    RETURN
1246 C
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
1254       ZW = IPMEM(ATTRAD)
1255       ZW = IAND (ISHFT(ZW, -4), 15) +1
1256       GOTO  (1000, 100, 200, 300, 1000, 400, 500, 1000,
1257      X       1000, 600), ZW
1258 C
1259 C...... TYP FORMALNY
1260   100 MPKIND = 3
1261       GOTO  1000
1262 C
1263 C...... FUNKCJA
1264   200 MPKIND = 4
1265       GOTO  1000
1266 C
1267 C...... PROCEDURA
1268   300 MPKIND = 5
1269       GOTO  1000
1270 C
1271 C...... INPUT
1272   400 MPKIND = 1
1273       GOTO  1000
1274 C
1275 C...... OUTPUT
1276   500 MPKIND = 2
1277       GOTO  1000
1278 C
1279 C.....INOUT
1280   600 MPKIND = 6
1281 C
1282 C*****************************************************************************
1283 C------ ZAKONCZENIE
1284  1000 IPMEM(CLLREC+7) = MPKIND
1285       RETURN
1286       END
1287 *DECK MPARTP
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
1296 C                  BLEDOW)
1297 C
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
1302 C
1303 C             /PROCEDURA TWORZY NOWA CZWORKE TYPOW DO MODYFIKACJI
1304 C
1305 C             OPIS W DOKUMENTACJI:             ?3.5
1306 C             WERSJA Z DNIA:                   19.01.82
1307 C             DLUGOSC KODU:         207
1308 C.............................................................................
1309 C
1310       IMPLICIT INTEGER (A-Z)
1311 C     *CALL BLANKSEM
1312 C.....
1313 #include "blank.h"
1314 C
1315 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1316 C     *CALL STCON
1317 C......
1318       LOGICAL  UNICLL
1319       COMMON /MCALLS/  CLLREC, UNICLL
1320 C
1321 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
1322 C
1323 C
1324 C...... POWROTY DLA WYWOLANIA NIEKONTROLOWANEGO
1325       IF (UNICLL)    RETURN
1326       IF (IPMEM(CLLREC+7) .EQ. 0)    RETURN
1327 C
1328 C------UTWORZENIE NOWEJ CZWORKI W REKORDZIE KONTROLI
1329       INSYS = .TRUE.
1330       K = MGETM(4, 0)
1331       INSYS = .FALSE.
1332 C...... ZAPIS NUMERU TYPU FORMALNEGO
1333       PF = IPMEM(CLLREC+5)
1334       IPMEM(K) = IPMEM(PF)
1335 C...... ZAPIS INFORMACJI O TYPIE AKTUALNYM
1336       IPMEM(K+1) = ATDIM
1337       IPMEM(K+2) = ATBASE
1338         IPMEM(K+3) = OB
1339 C...... KONTROLA, CZY TYP AKTUALNY JEST DOPUSZCZALNY
1340   100 PF = IPMEM(ATBASE)
1341       PF = IAND(PF, 15)
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
1350 C
1351 C------SYGNALIZACJA BLEDU - TYP AKTUALNY NIE JEST REFERENCYJNY
1352       CALL  MERR(624, IDBASE)
1353       IPMEM(K+2) = NRUNIV
1354       RETURN
1355 C------SYGNALIZACJA BLEDU- PARAMETR ATBASE NIE JEST TYPEM
1356   200 CALL  MERR(625, IDBASE)
1357   205 IPMEM(K+1) = 0
1358       IPMEM(K+2) = NRUNIV
1359       RETURN
1360 C-----PARAMETREM JEST TYP 'SEMAPHORE' - BLAD
1361   210 CALL  MERR(637, 0)
1362       GOTO  205
1363       END
1364 *DECK MREPTP
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-
1372 C             WANE
1373 C
1374 C             OPIS W DOKUMENTACJI:          ?3.6.1
1375 C             WERSJA Z DNIA:                19.01.82
1376 C             DLUGOSC KODU:        112
1377 C.............................................................................
1378 C
1379       IMPLICIT INTEGER (A-Z)
1380 C     *CALL BLANKSEM
1381 C.....
1382 #include "blank.h"
1383 C
1384 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1385 C     *CALL STCON
1386 C......
1387       LOGICAL  UNICLL
1388       COMMON /MCALLS/  CLLREC, UNICLL
1389 C
1390 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
1391 C
1392 C             K - INDEKS PIERWSZEJ PIATKI TYPOW ZASTEPOWANYCH
1393 C             L - INDEKS OSTATNIEJ PIATKI TYPOW ZASTEPOWANYCH
1394       L = LPML - 4
1395       K = CLLREC + 8
1396 C...... SPRAWDZENIE, CZY LISTA TYPOW NIE JEST PUSTA
1397       IF (K .GT. L)    RETURN
1398 C------ SZUKANIE W NIEPUSTEJ LISCIE
1399 C
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
1404       K = K+4
1405       GOTO  10
1406 C
1407 C------ TYP ODNALEZIONY
1408    20 TDIM = TDIM + IPMEM(K+1)
1409       TBAS = IPMEM(K+2)
1410       OB = IPMEM(K+3)
1411       RETURN
1412       END
1413 *DECK MCALLO
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
1421 C                     PROTOTYP POCHODZI
1422 C             PARAMETR WYJSCIOWY
1423 C               KIND - WARTOSCI
1424 C                      = 0  ZWYKLY PROTOTYP
1425 C                      = 1  WIRTUALNY
1426 C                      = 2  FORMALNY
1427 C
1428 C             OPIS W DOKUMENTACJI:         ?3.4.2
1429 C             WERSJA Z DNIA:               19.01.82
1430 C             DLUGOSC KODU:        262
1431 C.............................................................................
1432 C
1433       IMPLICIT INTEGER (A-Z)
1434       LOGICAL BTEST
1435 C
1436 C     *CALL BLANKSEM
1437 C.....
1438 #include "blank.h"
1439 C
1440 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1441 C     *CALL STCON
1442 C......
1443       LOGICAL  UNICLL
1444       COMMON /MCALLS/  CLLREC, UNICLL
1445 C
1446 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
1447 *CALL MID
1448       COMMON /MID/ PSTART, CHECKS
1449 C
1450 C------ UTWORZENIE REKORDU DLA WYWOLANIA UNIWERSALNEGO
1451       KIND = 0
1452       UNICLL = .TRUE.
1453       CHECKS = CHECKS+1
1454       INSYS = .TRUE.
1455       RECORD = MGETM(2, 0)
1456       IPMEM(RECORD) = CLLREC
1457       CLLREC = RECORD+1
1458       INSYS = .FALSE.
1459       IF (NRPROT .EQ. NRUNIV)    RETURN
1460 C------ UTWORZENIE REKORDU DLA WYWOLANIA KONTROLOWANEGO
1461       INSYS = .TRUE.
1462       UNICLL = .FALSE.
1463       RECORD = MGETM(7, 0)
1464       INSYS = .FALSE.
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
1471       KIND = 1
1472         IF (BTEST(RECORD, 11) )    GOTO  100
1473 C...... ZBADANIE, CZY TO PROTOTYP FORMALNY
1474 C         (PRZY POMOCY POLA  ZP)
1475       KIND = 0
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
1488 C       ZMIENNA RESULT
1489       RECORD = IAND( ISHFT(RECORD, -8), 7)
1490       IF (RECORD .EQ. 2)    IPMEM(CLLREC+6) =
1491      X                                                 IPMEM(CLLREC+6)-1
1492       RETURN
1493       END
1494 *DECK MCALLC
1495       SUBROUTINE  MCALLC
1496 C-------------ZAKONCZENIE KONTROLI WYWOLANIA, ZBADANIE
1497 C             ZGODNOSCI LICZBY PARAMETROW FORMALNYCH I PARAME-
1498 C             TROW AKTUALNYCH
1499 C             ZDJECIE REKORDU KONTROLI ZE STOSU
1500 C         SYGNALIZOWANY BLAD
1501 C             623 - LISTA PF JEST DLUZSZA OD LISTY PARAMETROW
1502 C                    AKTUALNYCH
1503 C
1504 C             OPIS W DOKUMENTACJI:        ?3.4.4.2
1505 C             WERSJA Z DNIA:              19.01.82
1506 C             DLUGOSC KODU:        89
1507 C.............................................................................
1508 C
1509 C
1510       IMPLICIT INTEGER (A-Z)
1511 C
1512 C     *CALL BLANKSEM
1513 C.....
1514 #include "blank.h"
1515 C
1516 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1517 C     *CALL STCON
1518 C......
1519       LOGICAL  UNICLL
1520       COMMON /MCALLS/  CLLREC, UNICLL
1521 C
1522 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
1523 *CALL MID
1524       COMMON /MID/ PSTART, CHECKS
1525 C
1526 C
1527       CHECKS = CHECKS - 1
1528       IF (UNICLL)    GOTO  1000
1529 C
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) )
1534 C
1535 C****** ZDJECIE REKORDU ZE SZCZYTU STOSU
1536  1000 LPML = CLLREC-1
1537       CLLREC = IPMEM(CLLREC-1)
1538       UNICLL = .FALSE.
1539       IF (IPMEM(CLLREC) .EQ. 0)    UNICLL = .TRUE.
1540       RETURN
1541       END
1542 *DECK MNOPF
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
1555 C
1556 C             OPIS W DOKUMENTACJI:           ?3.4.3.1
1557 C             WERSJA Z DNIA:                 19.01.82
1558 C             DLUGOSC KODU:        168
1559 C.............................................................................
1560 C
1561       IMPLICIT INTEGER (A-Z)
1562       LOGICAL BTEST
1563 C
1564 C     *CALL BLANKSEM
1565 C.....
1566 #include "blank.h"
1567 C
1568 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1569 C     *CALL STCON
1570 C......
1571       LOGICAL  UNICLL
1572       COMMON /MCALLS/  CLLREC, UNICLL
1573 C
1574 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
1575 C
1576       MNOPF = .TRUE.
1577       IF (UNICLL)    RETURN
1578       MNOPF = .FALSE.
1579 C
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
1585 C
1586 C****** PRZYPADEK, GDY NIE MA JUZ POTRZEBNEGO PF
1587 C         -SYGNALIZACJA BLEDU, GDY WYWOLYWANY PROTOTYP NIE JEST
1588 C             USZKODZONY
1589 C         -SKROCENIE REKORDU KONTROLI STATYCZNEJ DO WYWOLANIA UNIWERSAL-
1590 C             NEGO
1591 C
1592       MNOPF = .TRUE.
1593 C
1594 C       ZW - SLOWO ZEROWE PROTOTYPU
1595       ZW = IPMEM(CLLREC)
1596       ZW = IPMEM(ZW)
1597 C         ---SKOK DLA USZKODZONEJ LISTY
1598       IF (BTEST(ZW, 13))    GOTO  100
1599 C
1600 C------ SYGNALIZACJA BLEDU
1601       CALL  MERR(622, IPMEM(CLLREC+1))
1602 C------ SKROCENIE REKORDU KONTROLI
1603   100 CALL  MUNICL
1604       RETURN
1605       END
1606 *DECK MUNICL
1607       SUBROUTINE  MUNICL
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
1612 C
1613 C             OPIS W DOKUMENTACJI:         ?3.4.4.1
1614 C             WERSJA Z DNIA:               19.01.82
1615 C             DLUGOSC KODU:        31
1616 C.............................................................................
1617 C
1618       IMPLICIT INTEGER (A-Z)
1619 C
1620 C     *CALL BLANKSEM
1621 C.....
1622 #include "blank.h"
1623 C
1624 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1625 C     *CALL STCON
1626 C......
1627       LOGICAL  UNICLL
1628       COMMON /MCALLS/  CLLREC, UNICLL
1629 C
1630 C     !!!!!! END OF SUBSTITUTION OF COMDECK STCON FROM LOGLAN.14  !!
1631 C
1632       LPML = CLLREC+1
1633       UNICLL = .TRUE.
1634       IPMEM(CLLREC) = 0
1635       RETURN
1636       END
1637 *DECK MTPCON
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
1644 C              TYPEM FORMALNYM.
1645 C             /WARTOSCI :
1646 C               -1 - TYP TEN SAM, Z ROZNYCH OBIEKTOW
1647 C                0 - TYPY ROZNE
1648 C               +1 - TYP TEN SAM Z TEGO SAMEGO OBIEKTU
1649 C
1650 C             OPIS W DOKUMENTACJI:       ?2.2.3
1651 C             WERSJA Z DNIA:             19.01.82
1652 C             DLUGOSC KODU:        362
1653 C.............................................................................
1654 C
1655       IMPLICIT INTEGER  (A-Z)
1656 C
1657 C     *CALL BLANKSEM
1658 C.....
1659 #include "blank.h"
1660 C
1661 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1662 C     *CALL MTPC
1663 C......BLOK KOMUNIKACJI Z PROCEDURA  MTPCON
1664       COMMON /MTPC/ PRFXR, PRFXL
1665 C
1666 C     !!!!!! END OF SUBSTITUTION OF COMDECK MTPC FROM LOGLAN.14  !!
1667 C     *CALL MOB
1668 C......KOMUNIKACJA Z PROCEDURA  MOBJFD
1669       LOGICAL  WCL1,WCL2
1670       COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
1671 C
1672 C     !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14  !!
1673 C
1674 C*******************************************
1675 C     WARUNKI DOSTATECZNE NA TO BY TYP POCHODZIL Z TEGO
1676 C     SAMEGO OBIEKTU:
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
1680 C           W DISPLAY-U)
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********************************************
1693 C
1694       MTPCON = 0
1695       IF (TRBAS .NE. TLBAS)    RETURN
1696       MTPCON = -1
1697       IF ( (PRFXR .LE. 0) .OR. (PRFXL .LE. 0) )    RETURN
1698 C********************************************
1699 C         BADANIE WARUNKOW  (A) - (E)
1700       MTPCON = 1
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
1708 C       PRFXR
1709       STOB = P
1710       PRFX1 = PRFXR
1711       PRFX2 = PRFXL
1712       CALL  MOBJFD
1713       SLOBR = SLOB1
1714       SLOBL = SLOB2
1715 C         SLOB - OBIEKTY W LANCUCHU SL
1716 C         WCL1 = .TRUE. GDY POMIEDZY P A DRUGIM Z TYCH OBIEKTOW
1717 C         WYSTEPUJE KLASA
1718 C         WCL2 = .TRUE. GDY POMIEDZY TYMI OBIEKTAMI WYSTEPUJE
1719 C         KLASA
1720       IF ( (SLOBR .EQ. P) .AND. (SLOBL .EQ. P) )    RETURN
1721 C         --POWROT DLA PRZYPADKU (D)
1722 C
1723       MTPCON = -1
1724       IF (WCL2)    RETURN
1725 C         --POMIEDZY OBIEKTAMI WYSTAPILA KLASA
1726 C
1727 C......TESTOWANIE PRZYPADKU (C)
1728       IF ( (PRFXR .NE. SLOBR) .OR. (PRFXL .NE. SLOBL) )
1729      X                   GOTO  100
1730       STOB = SLOBR
1731       PRFX1 = IPMEM(TRBAS-1)
1732       PRFX2 = 0
1733       CALL  MOBJFD
1734       OBTPR = SLOB1
1735 C
1736       STOB = SLOBL
1737       PRFX1 = IPMEM(TLBAS-1)
1738       PRFX2 = 0
1739       CALL  MOBJFD
1740       OBTPL = SLOB1
1741       IF (OBTPR .NE. OBTPL)    RETURN
1742       MTPCON = 1
1743       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
1750 C       KLASA
1751       STOB = SLOBR
1752       PRFX1 = IPMEM(TRBAS-1)
1753       PRFX2 = 0
1754       CALL  MOBJFD
1755       OBTPR = SLOB1
1756       IF (WCL1 .AND. (SLOBR .NE. OBTPR) )    RETURN
1757       STOB = SLOBL
1758       PRFX1 = IPMEM(TLBAS-1)
1759       PRFX2 = 0
1760       CALL  MOBJFD
1761       OBTPL = SLOB1
1762       IF (WCL1 .AND. (SLOBL .NE. OBTPL) )    RETURN
1763       IF (OBTPL .NE. OBTPR)    RETURN
1764 C         --TYP BRANY Z ROZNYCH OBIEKTOW
1765       MTPCON = 1
1766       RETURN
1767       END
1768 *DECK MDISTP
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
1777 C             /WARTOSCI
1778 C              - .TRUE. - TYP ZAWSZE DOSTEPNY PRZEZ DISPLAY
1779 C              - .FALSE. - TYP NIE JEST LUB NIE ZAWSZE JEST DOSTEPNY
1780 C                PRZEZ DISPLAY
1781 C
1782 C             OPIS W DOKUMENTACJI:        ?1.4.4
1783 C             WERSJA Z DNIA:              19.01.82
1784 C             DLUGOSC KODU:       314
1785 C.............................................................................
1786 C
1787 C
1788       IMPLICIT INTEGER (A-Z)
1789       LOGICAL  BPREF
1790       LOGICAL  WCL, VWCL
1791 cdsw  DATA MDISTPHX /Z0FFF/
1792 C
1793 C     *CALL BLANKSEM
1794 C.....
1795 #include "blank.h"
1796 C
1797 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
1798 C     *CALL MOB
1799 C......KOMUNIKACJA Z PROCEDURA  MOBJFD
1800       LOGICAL  WCL1,WCL2
1801       COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
1802 C
1803 C     !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14  !!
1804 C
1805 cdsw  ---------------------
1806       data mdishx / x'0fff'/
1807 cdsw  -----------------------
1808       TPSL = IPMEM(NRPROT - 1)
1809       NRDIS = TPSL
1810 C          WARSTWA, Z KTOREJ POCHODZI TYP NRPROT
1811       MDISTP = .TRUE.
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
1816       MDISTP = .FALSE.
1817 C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO
1818 C     OBIEKTU Z WARSTWA VSL
1819       STOB = P
1820       PRFX1 = VSL
1821       PRFX2 = 0
1822       CALL  MOBJFD
1823       VOB = SLOB1
1824       VWCL = WCL2
1825 C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU AKTUALNEGO
1826 C     OBIEKTU Z WARSTWA TPSL
1827       STOB = P
1828       PRFX1 = TPSL
1829       CALL  MOBJFD
1830       TOB = SLOB1
1831       WCL = WCL2
1832       IF (TOB .EQ. VOB)    GOTO  100
1833       IF (VWCL)    RETURN
1834       IF (WCL)    RETURN
1835 C......ZNALEZIENIE W LANCUCHU SL PROTOTYPU VOB OBIEKTU
1836 C     Z WARSTWA  TPSL
1837       STOB = VOB
1838       PRFX1 = TPSL
1839       CALL  MOBJFD
1840       TOBPR = SLOB1
1841       WCL = WCL2
1842       IF ( TOB .NE. TOBPR)    GOTO  300
1843       IF ( .NOT. WCL)    GOTO  200
1844       NRDIS = VOB
1845       IF (VOB .NE. TOB)    RETURN
1846       MDISTP = .TRUE.
1847       RETURN
1848   100 MDISTP = .TRUE.
1849       NRDIS = VSL
1850       RETURN
1851   200 NRDIS = TOBPR
1852       MDISTP = .TRUE.
1853       RETURN
1854   300 IF (IAND(IPMEM(VOB),15) .NE. 1)    RETURN
1855       IF (WCL)    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
1859       GOTO  200
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
1863       END
1864 *DECK MOBJFD
1865       SUBROUTINE  MOBJFD
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
1873 C                   WYSTEPUJE KLASA
1874 C              WCL2 = .TRUE. JESLI POMIEDZY TYMI OBIEKTAMI WYSTE-
1875 C                   PUJE KLASA
1876 C
1877 C             OPIS W DOKUMENTACJI:        ?1.4.3
1878 C             WERSJA Z DNIA:              19.01.82
1879 C             DLUGOSC KODU:        548
1880 C.............................................................................
1881 C
1882       IMPLICIT INTEGER (A-Z)
1883       LOGICAL WCLPR, NOCL1, NOCL2, BPREF
1884 cdsw  DATA MOBJFDHX /Z0FFF/
1885 C     *CALL BLANK
1886 C.....
1887 #include "blank2.h"
1888 C
1889 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
1890 C     *CALL MOB
1891 C......KOMUNIKACJA Z PROCEDURA  MOBJFD
1892       LOGICAL  WCL1,WCL2
1893       COMMON /MOB/ STOB, PRFX1, PRFX2, SLOB1, SLOB2, WCL1, WCL2
1894 C
1895 C     !!!!!! END OF SUBSTITUTION OF COMDECK MOB FROM LOGLAN.14  !!
1896 C
1897 cdsw  -------------------
1898       data mobjhx / x'0fff'/
1899 cdsw  ---------------------
1900 C......INICJALIZACJA
1901       ACTOB = STOB
1902 C         -OBIEKT AKTUALNY W LANCUCHU SL
1903       WCL1 = .FALSE.
1904       WCL2 = .FALSE.
1905       WCLPR = .FALSE.
1906 C......SPRAWDZENIE, CZY PRFX SA KLASAMI JESLI TAK TO POBRANIE
1907 C         ICH NUMEROW W SENSIE ZBIOROW PREFIKSOW
1908       NOCL1 = .TRUE.
1909       NOCL2 = .TRUE.
1910       ZWORD = IAND(IPMEM(PRFX1), 15)
1911       IF ( (ZWORD .GE. 15) .OR. (ZWORD .EQ. 1) )
1912      X                       GOTO  100
1913         NOCL1 = .FALSE.
1914         PRFN1 = IPMEM(PRFX1-6)
1915 C         --PRFN1 - NUMER W SENSIE PREFXSET
1916 C
1917   100 IF (PRFX2 .EQ. 0)    GOTO  3000
1918 C         --SKOK DO WYSZUKIWANIA PROTOTYPU Z WARSTWA  PRFX1
1919 C
1920 C
1921       IF ( (IPMEM(PRFX2) .GE. 15) .OR. (IPMEM(PRFX2) .EQ. 1) )
1922      X                       GOTO  200
1923         NOCL2 = .FALSE.
1924         PRFN2 = IPMEM(PRFX2-6)
1925 C
1926   200 CONTINUE
1927       IF (PRFX1 .EQ. PRFX2)    GOTO  3100
1928 C
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)
1944       GOTO  1000
1945 C
1946 C
1947 C******WYSZUKIWANIE DRUGIEGO OBIEKTU, W PRZYPADKU GDY
1948 C         PIERWSZYM JEST ODPOWIADAJACY  PRFX1
1949  2000 SLOB1 = ACTOB
1950       IF ( (IPMEM(ACTOB) .LE. 15) .AND. (IPMEM(ACTOB) .NE. 1) )
1951      X                    WCLPR = .TRUE.
1952 C         ***BADANIE KOLEJNYCH OBIEKTOW
1953  2100 CONTINUE
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)
1962       GOTO  2100
1963 C
1964 C
1965 C         ***OBIEKT DRUGI ODNALEZIONY
1966  2500 SLOB2 = ACTOB
1967       IF ( SLOB1 .EQ. SLOB2)    RETURN
1968       WCL1 = ( (WCL1 .OR. WCL2) .OR. WCLPR)
1969       RETURN
1970 C
1971 C
1972 C******WYSZUKIWANIE DRUGIEGO OBIEKTU W PRZYPADKU, GDY PIERWSZYM
1973 C         JEST ODPOWIADAJACY PRFX2 (ROWNIEZ, GDY SZUKAMY JEDNEGO
1974 C         OBIEKTU)
1975  3000 SLOB2 = ACTOB
1976       ZWORD = IAND(IPMEM(ACTOB), mobjhx  )
1977       IF ( (ZWORD .LE. 15) .AND. (ZWORD .NE. 1) )
1978      X                       WCLPR = .TRUE.
1979 C         ***BADANIE KOLEJNYCH OBIEKTOW W CIAGU SL
1980  3100 CONTINUE
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)
1988       GOTO  3100
1989 C
1990 C
1991 C         ***ODNALEZIONY DRUGI OBIEKT
1992  3500 SLOB1 = ACTOB
1993       IF (PRFX1 .NE. PRFX2)    GOTO 3600
1994         WCL2 = .FALSE.
1995         SLOB2 = ACTOB
1996  3600 CONTINUE
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)
2002       RETURN
2003       END
2004 *DECK MARITH
2005       SUBROUTINE  MARITH ( OP )
2006 C-------------PROCEDURA BADA POPRAWNOSC ARGUMENTOW OPERACJI ARYTME-
2007 C             TYCZNYCH.
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
2017 C             WYNIKU OPERACJI .
2018 C             PROCEDURA PRZEKAZUJE INFORMACJE O KONWERSJI LEWEGO (CONVL)
2019 C             I PRAWEGO (CONVR) ARGUMENTU. WARTOSCI TYCH ZMIENNYCH
2020 C             OZNACZAJA :
2021 C               0 - BEZ KONWERSJI
2022 C               1 - INTEGER DO REAL
2023 C         ----SYGNALIZOWANE BLEDY :
2024 C             604 - TYP ARGUMENTU OPERACJI LUB RELACJI NIE JEST ARYTME-
2025 C                   TYCZNY,
2026 C             605 - TYP ARGUMENTU  DIV  LUB  MOD  NIE JEST INTEGER
2027 C
2028 C             OPIS W DOKUMENTACJI:         ?2.4
2029 C             WERSJA Z DNIA:               19.01.82
2030 C             DLUGOSC KODU:        295
2031 C.............................................................................
2032 C
2033       IMPLICIT INTEGER (A-Z)
2034 C
2035 C     *CALL BLANKSEM
2036 C.....
2037 #include "blank.h"
2038 C
2039 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2040 C
2041 C
2042 C------ KONTROLA TYPU LEWEGO ARGUMENTU
2043       TL = TLBAS
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
2048 C
2049 C...... TYP LEWEJ STRONY NIE JEST ARYTMETYCZNY
2050   100 TL = NRUNIV
2051         CALL  MERR(604, IDL)
2052 C
2053 C------KONTROLA TYPU PRAWEJ STRONY
2054   200 TR = TRBAS
2055       IF (TRDIM .NE. 0)    GOTO  300
2056       IF ((TRBAS .EQ. NRINT) .OR. (TRBAS .EQ. NRRE) .OR.
2057      X    (TRBAS .EQ. NRUNIV) )    GOTO  400
2058 C
2059 C......TYP PRAWEJ STRONY NIE JEST ARYTMETYCZNY
2060   300 TR = NRUNIV
2061         CALL  MERR(604, IDR)
2062 C
2063 C
2064 C------ SPRAWDZENIE ZALEZNE OD RODZAJU OPERACJI, USTALENIE KONWERSJI
2065   400 IF (OP-2)    500, 600, 700
2066 C
2067 C..... OP = 1 - OPERACJE  +,-,*  ORAZ RELACJE
2068   500 TRESLT = NRRE
2069 C         TYP REAL JEST SILNIEJSZY OD INTEGER. PRZYJMUJE WIEC, ZE JEST
2070 C         TO TYP WYNIKU.
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
2075       CONVL = 0
2076        IF (TL .NE. TRESLT)    CONVL = 1
2077       CONVR = 0
2078        IF (TR .NE. TRESLT)    CONVR = 1
2079       RETURN
2080 C
2081 C..... OP = 2 - OPERACJE  DIV  I  MOD
2082   600 TRESLT = NRINT
2083       CONVL = 0
2084       CONVR = 0
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)
2088         RETURN
2089 C
2090 C...... OP = 3 - OPERACJA  /
2091 C         WYNIK MUSI BYC TYPU REAL, ARGUMENTY PODLEGAJA EWENTUALNEJ
2092 C         KONWERSJI
2093   700 TRESLT = NRRE
2094       CONVL = 0
2095       CONVR = 0
2096       IF (TL .EQ. NRINT)    CONVL = 1
2097       IF (TR .EQ. NRINT)    CONVR = 1
2098       RETURN
2099       END
2100 *DECK MLOCTP
2101       LOGICAL  FUNCTION  MLOCTP (TP, PROT)
2102 C-------------FUNKCJA SPRAWDZA, CZY TYP TP JEST LOKALNYM ATRYBUTEM
2103 C             PROTOTYPU  PROT
2104 C
2105 C             OPIS W DOKUMENTACJI:        ?1.4.2
2106 C             WERSJA Z DNIA:              19.01.82
2107 C             DLUGOSC KODU:         107
2108 C.............................................................................
2109 C
2110       IMPLICIT INTEGER (A-Z)
2111       LOGICAL  BPREF
2112 C
2113 C     *CALL BLANKSEM
2114 C.....
2115 #include "blank.h"
2116 C
2117 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2118       MLOCTP = .TRUE.
2119 C
2120       SLTP = IPMEM(TP - 1)
2121 C       SLTP - MIEJSCE DEKLARACJI  TP
2122       IF (SLTP .EQ. PROT)    RETURN
2123       MLOCTP = .FALSE.
2124       IF ( IAND( IPMEM(SLTP), 15) .EQ. 1)    RETURN
2125 C         POWROT Z WARTOSCIA .FALSE. O ILE SLTP NIE MOZE PREFIKSOWAC
2126 C         PROTOTYPU  PROT
2127       IF ( IPMEM(PROT) .EQ. 1)    RETURN
2128       IF ( IAND(ISHFT(IPMEM(PROT), -8), 7) .EQ. 7)    RETURN
2129 C       --HANDLER
2130       IF ( BPREF (PROT, IPMEM(SLTP - 6) ) )    MLOCTP = .TRUE.
2131       RETURN
2132       END
2133 *DECK MAQUAB
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
2147 C                   FORMALNYM
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
2151 C
2152 C
2153 C             OPIS W DOKUMENTACJI:        ?1.5.2
2154 C             WERSJA Z DNIA:              19.01.82
2155 C             DLUGOSC KODU:       238
2156 C.............................................................................
2157       IMPLICIT INTEGER (A-Z)
2158 C
2159 C     *CALL BLANKSEM
2160 C.....
2161 #include "blank.h"
2162 C
2163 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2164 C
2165 C     ODSZUKIWANIE IDENTYFIKATORA
2166       MAQUAB = MIDENT (IDB)
2167 C
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
2172 C
2173 C     ...IDB JEST KLASA LUB TYPEM SYSTEMOWYM - GDY TO TYP SYSTEMOWY
2174 C         TO BLAD
2175   100   IF ( (MAQUAB .NE. NRCOR) .AND. (MAQUAB .NE. NRPROC) )
2176      X        GOTO  2000
2177 C       SKOK - GDY JEST TO ZWYKLY TYP KLASOWY
2178 C
2179 C     ...IDB NIE JEST TYPEM KLASOWYM
2180   200   CALL  MERR(617, IDB)
2181         MAQUAB = NRUNIV
2182         GOTO  2000
2183 C
2184 C     ...IDB NIE JEST TYPEM
2185  1000   CALL  MERR(616, IDB)
2186         MAQUAB = NRUNIV
2187 C
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
2194 C
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
2200           CALL  MERR(618, IDB)
2201           MAQUAB = NRUNIV
2202           RETURN
2203 C
2204 C     ...TYP PRZED QUA JEST FORMALNY
2205  2200   RETURN
2206 C
2207 C     ...TYP PRZED  QUA NIE JEST ODPOWIEDNI
2208  3000   CALL  MERR(615, IDL)
2209         MAQUAB = NRUNIV
2210  4000   RETURN
2211       END
2212 *DECK MTHIS
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
2226 C
2227 C             OPIS W DOKUMENTACJI:          ?1.5.1
2228 C             WERSJA Z DNIA:                19.01.82
2229 C             DLUGOSC KODU:        182
2230 C.............................................................................
2231 C
2232       IMPLICIT INTEGER (A-Z)
2233       LOGICAL  BPREF
2234 C
2235 C     *CALL BLANKSEM
2236 C.....
2237 #include "blank.h"
2238 C
2239 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2240 C
2241 C
2242       MTHIS = MIDENT (ID)
2243       IF (MTHIS .EQ. NRUNIV)    RETURN
2244 C
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
2248 C
2249 C-----PRZYPADEK, GDY  ID  JEST NAZWA TYPU KLASOWEGO LUB SYSTEMOWEGO
2250 C             PRZEJSCIE PO SL-ACH W POSZUKIWANIU MODULU PREFIKSOWANEGO
2251 C             PRZEZ  ID
2252 C             PROT - PROTOTYP BADANY
2253   100   PROT = P
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
2259 C         PREFIKSOWANIA
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
2270           CALL  MERR(612, ID)
2271           MTHIS = NRUNIV
2272           RETURN
2273 C.....ID WYSTAPILO JAKO PREFIKS PROTOTYPU  PROT
2274 C
2275 C-----ID NIE JEST NAZWA KLASY UOGOLNIONEJ
2276  8000   CALL  MERR(613, ID)
2277         MTHIS = NRUNIV
2278         RETURN
2279 C
2280 C
2281 C-----ID NIE JEST TYPEM
2282  9000   CALL  MERR(614, ID)
2283         MTHIS = NRUNIV
2284         RETURN
2285       END
2286 *DECK MDOT
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-
2291 C                   CJI BLEDOW),
2292 C             ID - NAZWA ZE SCANNERA IDENTYFIKATORA PO KROPCE.
2293 C               JESLI ATRYBUT JEST DOSTEPNY - WARTOSCIA  MDOT  JEST JEGO
2294 C             OPIS.
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
2303 C                  TAKEN,
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
2307 C                  LISTY  TAKEN
2308 C
2309 C             OPIS W DOKUMENTACJI:          ?1.6.1
2310 C             WERSJA Z DNIA:               19.01.82
2311 C             DLUGOSC KODU:       382
2312 C.............................................................................
2313 C
2314       IMPLICIT INTEGER (A-Z)
2315       LOGICAL MINSCP
2316 C       FUNKCJA POMOCNICZA DO BADANIA, CZY JESTESMY W ZASIEGU DEKLARACJI
2317 C
2318 C     *CALL BLANKSEM
2319 C.....
2320 #include "blank.h"
2321 C
2322 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2323 C     *CALL MEM
2324 C.....
2325 C     KOMUNIKACJA Z PROCEDURA MEMPRF
2326       COMMON  /MEM/  NM, NH
2327 C     !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
2328 C
2329 C
2330       IF (TDIM .NE. 0)    GOTO  1000
2331 C
2332 C------ TU TYPY NIETABLICOWE
2333       TP = IAND(IPMEM(TBAS), 15)
2334 C         TP - POLE T Z OPISU TYPU TBAS
2335 C
2336       GOTO (1000, 100, 100, 500, 400, 1000, 400, 1000, 1000, 1000,
2337      X      1000, 1000, 1000, 1000, 1000), TP
2338 C
2339 C------ TYPY POSIADAJACE ATRYBUTY (TZN. TYPY KLASOWE)
2340   100 NM = ID
2341         NH = IAND ( ISHFT(NM, -1), 7) + 1
2342         MDOT = MEMPRF (TBAS)
2343       IF (MDOT .NE. 0)    GOTO  200
2344 C------ TU - IDENTYFIKATOR NIEZADEKLAROWANY
2345         CALL  MERR(603, ID)
2346         MDOT = INSERT(ID, IPMEM(TBAS+10), 0)
2347         MDOT = NRUNIV
2348         RETURN
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
2359 C        W PREFIKSIE
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)
2371         RETURN
2372 C
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
2377         IPMEM(MDOT+1) = 0
2378         IPMEM(MDOT+2) = NRUNIV
2379   255 MDOT = NRUNIV
2380         RETURN
2381 C
2382 C
2383 C------ TU IDENTYFIKATORY "CLOSE" LUB STALE "CONST"
2384   300 NRE = 602
2385       NM = IPMEM(MDOT+2)
2386       IF (NM .EQ. NRUNIV)    GOTO  350
2387 C       --BADANIE, CZY TO STALA 'CONST'
2388         NM = ISHFT( IPMEM(NM), -4)
2389         NM = IAND(NM, 15)
2390         IF (NM .NE. 8)    GOTO  350
2391           NRE = 611
2392           GOTO  360
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)
2397       MDOT = NRUNIV
2398       RETURN
2399
2400 C
2401 C------OBIEKTY COROUTINE LUB PROCESS
2402   400 IF  ((TBAS .NE. NRCOR) .AND. (TBAS .NE. NRPROC))    GOTO  100
2403 C
2404 C------NIEPOPRAWNY TYP PRZED KROPKA
2405  1000 CALL  MERR(601, IDA)
2406 C------ TYP PRZED KROPKA JEST UNIWERSALNY
2407   500 MDOT = NRUNIV
2408       RETURN
2409       END
2410 *DECK MINSCP
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
2414 C                 PROTOTYPU P
2415 C
2416 C....................................................................
2417 C
2418       IMPLICIT INTEGER (A-Z)
2419 C
2420 C     *CALL BLANKSEM
2421 C.....
2422 #include "blank.h"
2423 C
2424 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2425 C
2426       MINSCP = .TRUE.
2427       PR = P
2428   100 IF (PR .EQ. T)    RETURN
2429       IF (PR .EQ. NBLSYS)    GOTO  200
2430       PR = IPMEM(PR-1)
2431       GOTO  100
2432   200 MINSCP = .FALSE.
2433       RETURN
2434       END
2435 *DECK MPROTO
2436       SUBROUTINE  MPROTO
2437 C---------------------------------PROCEDURA POMOCNICZA - OTWIERA POMOCNICZA
2438 C                         STRUKTURE DANYCH PRZY WEJSCIU DO INSTRUKCJI NOWEGO
2439 C                         PROTOTYPU
2440 C
2441 C............................................................................
2442 C
2443       IMPLICIT INTEGER (A-Z)
2444 C
2445 C     *CALL BLANKSEM
2446 C.....
2447 #include "blank.h"
2448 C
2449 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2450 *CALL MID
2451       COMMON /MID/ PSTART, CHECKS
2452 C
2453 C
2454       CHECKS = 0
2455       INSYS = .TRUE.
2456       PSTART = MGETM(8,0)
2457       INSYS = .FALSE.
2458       RETURN
2459       END
2460 *DECK MPROTC
2461       SUBROUTINE  MPROTC
2462 C---------------------------------PROCEDURA POMOCNICZA - ZAMYKA POMOCNICZA
2463 C                         STRUKTURE DANYCH PRZY WYJSCIU Z PROTOTYPU
2464 C
2465 C........................................................................
2466 C
2467       IMPLICIT INTEGER (A-Z)
2468 C
2469 C     *CALL BLANKSEM
2470 C.....
2471 #include "blank.h"
2472 C
2473 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2474 *CALL MID
2475       COMMON /MID/ PSTART, CHECKS
2476 C
2477 C
2478       LPML = PSTART
2479       RETURN
2480       END
2481 *DECK MIDENT
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
2486 C                         POMOCNICZEJ
2487 C
2488 C.............................................................................
2489 C
2490       IMPLICIT INTEGER (A-Z)
2491 C
2492 C     *CALL BLANKSEM
2493 C.....
2494 #include "blank.h"
2495 C
2496 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2497 *CALL MID
2498       COMMON /MID/ PSTART, CHECKS
2499 C
2500 C
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
2505 C         ZADNYCH BLEDOW
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
2512       RETURN
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
2518       INSYS = .TRUE.
2519       NADR = MGETM(5,0)
2520       INSYS = .FALSE.
2521       MIDENT = IPMEM(MIDENT+2)
2522       IPMEM(NADR) = ID
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)
2529       IPMEM(NH) = NADR
2530       RETURN
2531   200 MIDENT = IPMEM(MIDENT+2)
2532       RETURN
2533       END
2534 *DECK MIDB
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-
2542 C                   TORA .
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
2550 C
2551 C
2552 C             OPIS W DOKUMENTACJI:         ?1.4.1
2553 C             WERSJA Z DNIA:               19.01.82
2554 C             DLUGOSC KODU:       155
2555 C.............................................................................
2556       IMPLICIT INTEGER (A-Z)
2557 C
2558 C     *CALL BLANKSEM
2559 C.....
2560 #include "blank.h"
2561 C
2562 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANKSEM FROM LOGLAN.14 !!
2563 C
2564 C
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
2570 C        WTEDY HIDDEN .
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
2578       RETURN
2579 C
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)
2584       LOCAL = 2
2585       RETURN
2586 C
2587 C...... SYGNALIZACJE BLEDOW DLA NIEDOSTEPNYCH ATRYBUTOW
2588  1200 CALL  MERR(620, ID)
2589       IF (.NOT. OWN)    GOTO  1100
2590       IPMEM(MIDB+1) = 0
2591       IPMEM(MIDB+2) = NRUNIV
2592       RETURN
2593  1300 CALL  MERR(619, ID)
2594       GOTO  1100
2595 C
2596       END
2597 *NEWDECK MEMSL
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
2602 C             NIE BYLO.
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
2607 C             LISTY HASH-U.
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
2612 C                      NAZWIE NAME
2613 C
2614 C             OPIS W DOKUMENTACJI:       B.III.2.4
2615 C             WERSJA Z DNIA:             19.01.82 (MJL)
2616 C             DLUGOSC KODU:       117
2617 C.......................................................................
2618 C
2619       IMPLICIT INTEGER (A-Z)
2620 C
2621 C     *CALL BLANK
2622 C.....
2623 #include "blank2.h"
2624 C
2625 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
2626 C     *CALL MEM
2627 C.....
2628 C     KOMUNIKACJA Z PROCEDURA MEMPRF
2629       COMMON  /MEM/  NM, NH
2630 C     !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
2631 C
2632         NM = NAME
2633       NH = IAND( ISHFT(NAME, -1), 7) + 1
2634 C        NH - WARTOSC FUNKCJI HASZUJACEJ DLA SZUKANEJ NAZWY
2635 C
2636       LOCAL = 2
2637       ISL = IDPROT
2638 C        ISL - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW
2639 C
2640 C *****
2641 C
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
2646 C
2647 C ..... NAZWA NIEODNALEZIONA W PROTOTYPIE ISL - POBRANIE NOWEGO PROTOTY-
2648 C       PU
2649       IF (ISL .EQ. NBLSYS)    GOTO  1000
2650 C        SKOK - JESLI DOSZLISMY DO BLOKU SYSTEMOWEGO NIE ZNAJDUJAC
2651 C        NAZWY - BEDZIE TO POWROT
2652       ISL = IPMEM(ISL-1)
2653       LOCAL = 1
2654       GOTO  10
2655 C *****
2656 C .... NAZWA ODNALEZIONA
2657    20 IF (ISL .EQ. NBLUS)    LOCAL = 0
2658       RETURN
2659 C
2660 C .... NAZWA NIEODNALEZIONA
2661  1000 MEMSL =0
2662       RETURN
2663       END
2664 *DECK MEMPRF
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
2669 C             NIE BYLO.
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
2673 C             LISTY HASH-U.
2674 C             OPIS W DOKUMENTACJI:        B.III.2.3
2675 C             WERSJA Z DNIA:              19.01.82 (MJL)
2676 C             DLUGOSC KODU:       261
2677 C.......................................................................
2678 C
2679 C
2680       IMPLICIT INTEGER (A-Z)
2681 C
2682 C     *CALL BLANK
2683 C.....
2684 #include "blank2.h"
2685 C
2686 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
2687 C     *CALL MEM
2688 C.....
2689 C     KOMUNIKACJA Z PROCEDURA MEMPRF
2690       COMMON  /MEM/  NM, NH
2691 C     !!!!!! END OF SUBSTITUTION OF COMDECK MEM FROM LOGLAN.14 !!
2692 C
2693 C
2694       IPR = IDPROT
2695       OBJECT = IDPROT
2696       OWN = .TRUE.
2697 C        IPR - IDENTYFIKATOR KOLEJNYCH PROTOTYPOW
2698 C
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,
2706 C            I POPRZEDNI
2707 C *****
2708    10 J = IPR+ NH+ 9
2709       J = IPMEM(J)
2710       I = -1
2711 C ..... SZUKANIE W PROTOTYPIE IPR
2712    20   IF (J.EQ.0)    GOTO  25
2713 C          SKOK - NAZWA NIEODNALEZIONA - POBIERAMY KOLEJNY PROTOTYP
2714 C
2715         IF (IPMEM(J).EQ. NM)    GOTO  100
2716 C          SKOK - NAZWA ODNALEZIONA
2717 C
2718         I =J
2719         J = IPMEM (J+3)
2720         GOTO  20
2721 C .....
2722 C      NAZWA NIEODNALEZIONA W PREFIKSIE  IPR - POBRANIE NOWEGO
2723 C          PREFIKSU
2724 C
2725    25 OWN = .FALSE.
2726 C     PRZEJSCIE DO PREFIKSU
2727       IPR = IPMEM(IPR+21)
2728       IF (IPR .NE. 0)    GOTO  10
2729       GOTO  1000
2730 C
2731 C *****
2732 C
2733 C ..... NAZWA ODNALEZIONA
2734   100 MEMPRF = J
2735       OBJECT = IPMEM(J+2)
2736 C       MIEJSCE DEKLARACJI
2737       OBJECT = IPMEM(OBJECT-1)
2738         IF (I.NE.-1)    GOTO  110
2739           RETURN
2740 C          PRZESUNIECIE ELEMENTU NA POCZATEK LISTY
2741   110   IPMEM(I+3) = IPMEM (J+3)
2742         I = IPR+ NH + 9
2743         IPMEM(J+3) = IPMEM(I)
2744         IPMEM(I) = J
2745       RETURN
2746 C
2747 C.....BLOKI ZWYKLE, HANDLERY I PROTOTYPY FORMALNE
2748   500 MEMPRF = MEMBER(NM, IPMEM(IPR+10))
2749       RETURN
2750 C
2751 C
2752 C .... NAZWA NIEODNALEZIONA
2753  1000 MEMPRF =0
2754       RETURN
2755       END
2756 *DECK INSERT
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
2763 C                POLE NAZWY - NAME
2764 C                BITY HIDDEN, CLOSE, NOT TAKEN - 0
2765 C                IDENTYFIKATOR ATRYBUTU - NRUNIV
2766 C            / NROVF - NUMER SYGNALIZOWANEGO PRZEPELNIENIA
2767 C
2768 C             OPIS W DOKUMENTACJI:         B.III.2.1
2769 C             WERSJA Z DNIA:        19.01.82 (MJL)
2770 C             DLUGOSC KODU:    95
2771 C.......................................................................
2772 C
2773       IMPLICIT INTEGER (A-Z)
2774       INTEGER THASH(8)
2775 C
2776 C     *CALL BLANK
2777 C.....
2778 #include "blank2.h"
2779 C
2780 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
2781 C
2782 C ..... REZERWACJA PAMIECI NA ELEMENT LISTY HASH-U
2783       INSERT = MGETM(4, NROVF)
2784 C
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)
2790       THASH(NH) = INSERT
2791       RETURN
2792       END
2793 *DECK MEMBER
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.
2800 C
2801 C             OPIS W DOKUMENTACJI:        B.III.2.2
2802 C             WERSJA Z DNIA:              19.01.82 (MJL)
2803 C             DLUGOSC KODU:        155
2804 C......................................................................
2805 C
2806       IMPLICIT INTEGER (A-Z)
2807       INTEGER THASH (8)
2808 C
2809 C     *CALL BLANK
2810 C.....
2811 #include "blank2.h"
2812 C
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
2817 C
2818 C        I,J - WSKAZNIKI PORUSZANIA SIE PO LISCIE
2819 C          J - WSKAZNIK AKTUALNY, I - POPRZEDNI
2820       I=-1
2821       J = THASH(NH)
2822 C
2823    10 IF (J.EQ.0)    GOTO  200
2824 C        SKOK - JESLI ATRYBUT NIE ZOSTAL ODNALEZIONY
2825 C
2826         IF (IPMEM(J) .EQ. NAME )    GOTO  100
2827 C           SKOK - JESLI ATRYBUT ODNALEZIONY
2828         I = J
2829         J = IPMEM(J+3)
2830         GOTO  10
2831 C
2832 C ..... NAZWA ODNALEZIONA
2833   100 MEMBER = J
2834         IF (I.NE. -1)    GOTO  110
2835         RETURN
2836 C          PRZESUNIECIE ELEMENTU LISTY NA POCZATEK LISTY
2837   110   IPMEM(I+3) = IPMEM(J+3)
2838         IPMEM(J+3) = THASH(NH)
2839         THASH(NH) = J
2840       RETURN
2841 C
2842 C ..... NAZWA NIEODNALEZIONA
2843   200 MEMBER = 0
2844       RETURN
2845       END
2846 *DECK MGETM
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
2856 C
2857 C             OPIS W DOKUMENTACJI:      B.III.1
2858 C             WERSJA Z DNIA:            19.01.82 (MJL)
2859 C             DLUGOSC KODU:       145
2860 C...........................................................................
2861 C
2862 C             ZAREZERWOWANA PAMIEC JEST WYZEROWANA
2863 C
2864       IMPLICIT INTEGER (A-Z)
2865 C
2866 C     *CALL BLANK
2867 C.....
2868 #include "blank2.h"
2869 C
2870 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
2871 C
2872       IF ( (LPML+ISIZE) .GT. LPMF)    GOTO  1000
2873 C             SKOK - GDY WOLNY OBSZAR JEST ZA MALY
2874       IF (INSYS)    GOTO  100
2875 C
2876 C ..... PRZYDZIAL PAMIECI W CZESCI UZYTKOWNIKA
2877       LPMF = LPMF - ISIZE
2878         DO  50  I = 1, ISIZE
2879           J = LPMF + I
2880           IPMEM(J) = 0
2881    50   CONTINUE
2882       MGETM = LPMF + 1
2883       GOTO  500
2884 C
2885 C ..... PRZYDZIAL PAMIECI W CZESCI SYSTEMOWEJ
2886   100 MGETM = LPML
2887         DO  150  I = 1, ISIZE
2888           J = LPML + I
2889           IPMEM(J - 1) = 0
2890   150   CONTINUE
2891       LPML = LPML + ISIZE
2892 C.....SPRAWDZENIE WYKORZYSTANIA PAMIECI
2893   500 X = LPMF-LPML
2894       IF (X .LT. COM(4))    COM(4) = X
2895       RETURN
2896 C
2897 C
2898 C ..... BRAK MIEJSCA W PAMIECI
2899  1000 CALL MDROP(NROVF)
2900 C
2901       END
2902 *DECK MPRFSQ
2903       INTEGER FUNCTION    MPRFSQ (IDPR1, IDPR2)
2904 C-------------BADA RODZAJ PREFIKSOWANIA TYPOW IDPR1 I IDPR2
2905 C             WARTOSCI
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
2910 C
2911 C             OPIS W DOKUMENTACJI:          B.III.4.3
2912 C             WERSJA Z DNIA:                19.01.82 (MJL)
2913 C             DLUGOSC KODU:        79
2914 C........................................................................
2915 C
2916       IMPLICIT INTEGER (A-Z)
2917       LOGICAL BPREF
2918 C
2919 C     *CALL BLANK
2920 C.....
2921 #include "blank2.h"
2922 C
2923 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
2924 C
2925       K1 = IPMEM(IDPR1-6)
2926       K2 = IPMEM(IDPR2-6)
2927 C        K1,K2 - NUMERY TYPOW W SENSIE PREFIXSET
2928       IF (BPREF(IDPR2, K1))    GOTO  20
2929       IF (BPREF(IDPR1, K2))    GOTO 30
2930 C
2931 C ..... ROZLACZNE SEKWENCJE PREFIKSOWE
2932       MPRFSQ = -1
2933       RETURN
2934 C ..... IDPR1 PREFIKSUJE IDPR2
2935    20 MPRFSQ = 0
2936       RETURN
2937 C ..... IDPR2 PREFIKSUJE IDPR1
2938    30 MPRFSQ = +1
2939       RETURN
2940 C
2941       END
2942 *DECK BPREF
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
2948 C
2949 C
2950 C             OPIS W DOKUMENTACJI:          B.III.4.1
2951 C             WERSJA Z DNIA:                19.03.82 (MJL)
2952 C             DLUGOSC KODU:        255
2953 C.........................................................................
2954 C
2955       IMPLICIT INTEGER (A-Z)
2956       LOGICAL BTEST
2957 C
2958 C     *CALL BLANK
2959 C.....
2960 #include "blank2.h"
2961 C
2962 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
2963 C
2964       IF (NRPREF .GT. 47)    GOTO  300
2965       K=NRPREF/16
2966       IF ( IAND(IPMEM(IDPROT), 15) .NE. 1)    GOTO  100
2967         BPREF = .FALSE.
2968         IF (IPMEM(IDPROT+21) .EQ. 0 )    RETURN
2969         K = IPMEM(IDPROT+21) -3-K
2970         GOTO  200
2971   100 K=IDPROT-3-K
2972   200 K=IPMEM(K)
2973 C        K SLOWO W PREFIXSET, W KTORYM NALEZY ZBADAC BIT ODPOWIADAJACY
2974 C                NRPREF
2975 C
2976       L=IAND(NRPREF,15)
2977 C        L - NUMER TESTOWANEGO BITU -   L = IMOD(NRPREF,16)
2978 C
2979       BPREF = BTEST (K,L)
2980       RETURN
2981   300 BPREF = .TRUE.
2982       IPR = IDPROT
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
2986       IDL = IPMEM(IPR+23)
2987       IPR = IPMEM(IPR+22)
2988   400 PRFX= IPMEM(IPR)
2989         IF (IPMEM(PRFX-6) .EQ. NRPREF)    RETURN
2990         IDL = IDL-1
2991         IPR = IPR+1
2992       IF (IDL .NE. 0)    GOTO  400
2993   500 BPREF = .FALSE.
2994       RETURN
2995       END
2996
2997       SUBROUTINE  MDROP(NROVFL)
2998 C-------------PROCEDURA PRZERYWA DZIALANIE MODULU.
2999 C             WYWOLYWANA JEST W PRZYPADKU PRZEPELNIEN JAKIEJKOLWIEK TAB-
3000 C             LICY KOMPILATORA.
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".
3005 C
3006 C             OPIS W DOKUMENTACJI:       B.I.2
3007 C             WERSJA Z DNIA:             19.01.82 (MJL)
3008 C             DLUGOSC KODU:       101
3009 C......................................................................
3010 C
3011       IMPLICIT INTEGER (A-Z)
3012 C
3013 C.....
3014 #include "blank3.h"
3015       LOGICAL  ERRFLG
3016 C
3017       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3018 C             ERRFLG - FLAGA BLEDOW
3019 C
3020 C     SYGNALIZOWANIE BLEDU
3021       LINE = 9999
3022       CALL  MERR(NROVFL, 0)
3023 C
3024       DROPFG = .TRUE.
3025 C     ERRFG = .TRUE.
3026       IOP(1) = IOP(1)+7
3027       CALL  MESS
3028       CALL  ML2
3029       RETURN
3030       END
3031
3032       SUBROUTINE  MERR(NRE, ID)
3033 C--------------PROCEDURA WPISUJACA SYGNALIZACJE BLEDOW NA STRUMIEN  2
3034 C             NRE - NUMER BLEDU
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.
3042 C
3043 C             OPIS W DOKUMENTACJI:    B.I.1
3044 C             WERSJA Z DNIA:          19.01.82 (MJL)
3045 C             DLUGOSC KODU:       146
3046 C.................................................................
3047 C
3048       IMPLICIT INTEGER (A-Z)
3049 C
3050 C     *CALL STREAM
3051       LOGICAL  ERRFLG
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  !!
3055 C     *CALL MJLMSG
3056       COMMON /MJLMSG/ IERC, MSG
3057 C     !!!!!! END OF SUBSTITUTION OF COMDECK MJLMSG FROM LOGLAN.14 !!
3058
3059 cdeb --------------------- added =----------------
3060       common /debug/deb,breakt(500),brnr,maxbr
3061       logical deb
3062 cdeb ---------------------------------------
3063 C
3064 C
3065 C----- ZBADANIE, CZY JEST TO PIERWSZY SYGNALIZOWANY BLAD
3066       IF (ERRFLG)    GOTO  100
3067
3068 C..... PRZYPADEK, GDY BLAD JEST SYGNALIZOWANY PO RAZ PIERWSZY
3069       ERRFLG = .TRUE.
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
3074 cdeb
3075       deb = .false.
3076 cdeb
3077
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-
3085 C             NEGO
3086 C       SLOWO 10 -LICZBA TROJEK WPISANYCH DO BLOKU
3087 C       SLOWA 10-265 -AKTUALNIE TWORZONY BLOK (TROJKI ZAPISYWANE OD SLO-
3088 C             WA 11)
3089 C
3090       IBUF2(8) = 0
3091       IBUF2(9) = 11
3092 C
3093 C-----WPISANIE SYGNALIZACJI BLEDU
3094   100 IERC = IERC+1
3095       POZ = IBUF2(9)
3096 C       POZ - AKTUALNA POZYCJA DO WYPELNIENIA
3097 C     ZAPISANIE NUMERU LINII, NUMERU BLEDU I IDENTYFIKACJI
3098       IBUF2(POZ) = LINE
3099       IBUF2(POZ+1) = NRE
3100       IBUF2(POZ+2) = ID
3101 C     MODYFIKACJA BUFORA
3102       POZ = POZ+3
3103       IBUF2(9) = POZ
3104       IF (POZ .LE. 263)    RETURN
3105 C     ..... JESLI BLOK ZOSTAL ZAPELNIONY, ZAPISANIE GO NA DYSK
3106       IBUF2(8) = IBUF2(8) + 1
3107       IBUF2(9) = 11
3108       IBUF2(10) = 85
3109       CALL  PUT(IBUF2, IBUF2(10))
3110       RETURN
3111       END
3112
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
3118 C
3119 C             OPIS W DOKUMENTACJI:          B.III.3
3120 C             WERSJA Z DNIA:                19.01.82 (MJL)
3121 C             DLUGOSC KODU:        99
3122 C.........................................................................
3123 C
3124       IMPLICIT INTEGER (A-Z)
3125 C
3126 C     *CALL BLANK
3127 C.....
3128 #include "blank2.h"
3129 C
3130 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
3131 C
3132       IACT = MGETM(2, NROVF)
3133       IPMEM(IACT) = IDATR
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
3140       IOST = IPMEM(IOST)
3141 C        IOST - OSTATNI ATRYBUT - INDEKS OPISU
3142       IPMEM(IDATR-1) = IDPROT
3143       IPMEM(IDATR-2) = IPMEM(IOST-2) + 1
3144       RETURN
3145       END
3146       SUBROUTINE    MSETB (IDPROT, NRPREF)
3147 C-------------W ZBIORZE PREFIXSET TYPU IDENTYFIKOWANEGO PRZEZ IDPROT
3148 C             USTAWIA BIT  NRPREF  NA 1
3149 C
3150 C             OPIS W DOKUMENTACJI:       B.III.4.2
3151 C             WERSJA Z DNIA:             19.03.82 (MJL)
3152 C             DLUGOSC KODU:        87
3153 C.......................................................................
3154 C
3155       IMPLICIT INTEGER (A-Z)
3156 C
3157 C     *CALL BLANK
3158 C.....
3159 #include "blank2.h"
3160 C
3161 C     !!!!!! END OF SUBSTITUTION OF COMDECK BLANK FROM LOGLAN.14  !!
3162 C
3163       IF (NRPREF .GT. 47)    RETURN
3164       K= NRPREF/16
3165       K= IDPROT-3-K
3166 C        K - INDEKS MODYFIKOWANEGO ELEMENTU PREFIXSET
3167 C
3168       L= IAND(NRPREF,15)
3169 C        L - NUMER ZAPALANEGO BITU
3170       L= ISHFT(1,L)
3171 C
3172       IPMEM(K) = IOR ( IPMEM(K), L)
3173       RETURN
3174       END
3175