sources/pass1/dsw.f

   1 C    Loglan82 Compiler&Interpreter
   2 C     Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3 C     Copyright (C)  1993, 1994 LITA, Pau
   4 C
   5 C     This program is free software; you can redistribute it and/or modify
   6 C     it under the terms of the GNU General Public License as published by
   7 C     the Free Software Foundation; either version 2 of the License, or
   8 C     (at your option) any later version.
   9 C
  10 C     This program is distributed in the hope that it will be useful,
  11 C     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 C     GNU General Public License for more details. File: LICENSE.GNU
  14 C  ===============================================================
  15
  16       SUBROUTINE DSW
  17 C
  18 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  19 C      ( BYLY ) PROGRAM GLOWNY
  20 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  21 C
  22       IMPLICIT INTEGER (A - Z )
  23 C
  24 C
  25       COMMON /MJLMSG/ IERC,MSG
  26       integer*4 msg
  27 C
  28 C
  29 C   BUFORY
  30 C
  31 C
  32 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
  33       LOGICAL  ERRFLG
  34       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
  35 C
  36 C
  37 C.....
  38 c$include:'blank.for'
  39
  40 cdeb --------------------- added -------------------
  41       common /debug/ deb, breakt(500),brnr,maxbr
  42       logical deb
  43 cdeb ------------------------------------------------
  44 C
  45       IERC=0
  46       msg = 'dsw '
  47 C
  48 C
  49        CALL INITMK
  50 C   SUBROUTINE INIT RENAMED TO INITMK         03.01.84   **********************
  51        CALL DPASS
  52 C
  53 C
  54 C
  55       CALL MESS
  56 cdeb      CALL AL1
  57 cdeb ------------- added --------------
  58        if(deb.and..not.errflg) go to 1000
  59        call al1
  60        return
  61 1000   call ts2
  62 cdeb ----------------------------------
  63        END
  64
  65       BLOCK DATA  BLKD
  66       IMPLICIT INTEGER (A-Z)
  67 C
  68 cdeb
  69       common /pr/ prot(5000),ind
  70 c   prot - tablica na prototypy debuggera
  71 c   ind - ostatnie zajete miejsce w tablicy
  72 cdeb
  73 C
  74 C
  75       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
  76      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
  77 cdsw  INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW, INOUT
  78 C
  79 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
  80 C    NULLWD(I)  -  WZORZEc SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
  81 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
  82 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
  83 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
  84 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
  85 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
  86 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
  87 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
  88 C    INOUT  -     --   --   --   ---           ZMIENNEJ INOUT
  89 C
  90 C
  91       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
  92      * MPROCES, MCOR, MERPF, MBLOCK, MHAND
  93      *, MNOTVIR
  94 C
  95 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
  96 C   MASKI I WZORCE:
  97 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
  98 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
  99 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
 100 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
 101 C    MASKTP - ZAPRZECZENIE MASKI  MTP
 102 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
 103 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
 104 C    MCOR - WZORZEC DLA COROUTINY (7)
 105 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
 106 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
 107 C    MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
 108 C    MHAND - WZORZEC DLA HANDLERA
 109 C
 110 C
 111 cdeb------------------------------------------
 112 cdeb      COMMON /NAMES/ RESNM,MAINM
 113       common /names/ resnm,mainm,brenam
 114 cdeb------------------------------------------
 115 C
 116 C   NAZWY ZE SCANNERA
 117 C  * * * * * * * * * * * * * * * * *  * * * * * * * * * * * * *
 118 C
 119 C
 120 C     COMMON  / WYDR /  KD(8), KSP(4)
 121 C     REAL KD,KSP
 122 C
 123 C    BLOK UZYWANY W PROCEDURYCH DRUKUJACYCH.
 124 C    KD(KIND+1)  -  ODPOWIEDNI TEKST DLA PROTOTYPU RODZAJU KIND
 125 C    KSP(KSPEC+1)  -  ODPOWIEDNI TEKST DLA PROTOTYPU RODZAJU KSPEC.
 126 C   **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 127 C
 128 C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 129 C  RODZAJE PROTOTYPOW:
 130 C   1 - BLOK, 2 - REKORD, 3 - PROCEDURA, 4 - FUNKCJA, 5 - PROC. Z BLEDNA PF
 131 C   6 - FUNKCJA Z BLEDNA LISTA PF, 7 - KLASA Z BLEDNA LISTA PF
 132 C   8 - BLOK PREFIKSOWANY, 9 - PROCEDURA VIRTUALNA, 10 I FUNKCJA VIRTUALNA
 133 C   11 - PROC. VIRTUALNA Z BLEDNA PF, 12 - FUNKCJA VIRTUALNA Z BLEDNA PF
 134 C   13 - PROCEDURA FORMALNA, 14 - FUNKCJA FORMALNA, 15 - PROC. FORMALNA
 135 C   Z BLEDNA LISTA PF, 16 - FUNKCJA FORMALNA Z BLEDNA LISTA PF,
 136 C  17 - TYP FORMALNY, 18 - PROCEDURA FORMALNA II-GO RZEDU,
 137 C   19 - FUNKCJA FORMALNA II-GO RZEDU
 138 C   20 - TYP FORMALNY II-GO RZEDU
 139 C   21 - SYGNAL, 22 - SYGNAL Z USZKODZONA LISTA PF, 23 - HANDLER
 140 C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 141 C
 142 C
 143       DATA SIZEPR/23,33,28,31,28,31,33,28,30,33,30,33,20,23,20,23,
 144      * 5,5,7,5,19, 19, 21/
 145       DATA NULLPOZ/2,7,2,5,2,5,7,2,2,5,2,5,2,5,2,5,2,2,4,2,1,1,2/
 146       DATA CONSTWD,VARWD,VARPOM,INPFW,OUTPFW / 129,113,65,81,97 /
 147       DATA INOUT /145/
 148       DATA NOTTP,MPROCES,MCOR,MBLOCK /1,5,7,0 /
 149 C     DATA KD(1) /5HTYP F/
 150 C     DATA KD(2)/4HKLAS/
 151 C     DATA KD(3) / 4HFUN   /
 152 C     DATA KD(4) / 4HPROC/
 153 C     DATA KD(5) / 4HBLOK/
 154 C     DATA KD(6) /4HBLPR/
 155 C     DATA KD(7) /6HSIGNAL/
 156 C     DATA KD(8) /5HHANDL/
 157 C     DATA KSP(1) /4HREK  /
 158 C     DATA KSP(2) / 4HKLAS/
 159 C     DATA KSP(3) / 4HPRSS/
 160 C     DATA KSP(4) / 4HCORO/
 161       DATA RESNM,MAINM / 2769,819 /
 162 cdeb ------------- added ---------------
 163       data brenam /7797/
 164 cdeb ----------------------------------
 165       DATA NULLWD / 1,2,1025,513,9217,8705,8194,257,3073,2561,11265,
 166      * 10753,1073,545,9265,8737,22,1073,545,22,177,8369,1793/
 167 cdeb
 168       data prot /5000*-100/
 169 cdeb
 170       END
 171       SUBROUTINE DPASS
 172 C
 173 C  * * * * * * * * * * * * * * * * * * ** * * * * * * * * * * * *
 174 C    PODPROGRAM REALIZUUACY PRZETWARZANIE PROTOTYPOW
 175 C  * * * * * * * * * * * * * *  * * * * * * * * * * * * * * * * *
 176 C
 177       IMPLICIT iNTEGER (A-Z)
 178 C
 179       COMMON  / QUEUE /  BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
 180 cdsw      INTEGER  BQUEUE, EQUEUE
 181       LOGICAL EMPTY
 182 C
 183 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 184 C    ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
 185 C      BQUEUE  -  POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
 186 C      EQUEUE  -  KONIEC      --      --       --      --      --
 187 C      IFIRST  -  PIERWSZY ELEMENT KOLEJKI
 188 C      LAST  -  OSTATNI ELEMENT KOLEJKI
 189 C      EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
 190 C
 191 C
 192 C
 193       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
 194      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
 195 cdsw  INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
 196 C
 197 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 198 C    NULLWD(I)  -  WZORZEc SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
 199 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
 200 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
 201 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
 202 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
 203 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
 204 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
 205 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
 206 C    INOUT  -    --   --   --  --    ---       ZMIENNEJ INOUT
 207 C
 208 C
 209 C ..... ZMIENNE GLOBALNE
 210 C
 211 C.....
 212       LOGICAL  INSYS,  OWN
 213       COMMON /BLANK/ COM(278),
 214      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 215      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 216      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 217      X        LOCAL , OWN   , OBJECT,
 218      X        IPMEM(5000)
 219 C
 220 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
 221 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
 222 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
 223 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
 224 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
 225 C
 226 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
 227 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
 228 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
 229 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
 230 C
 231 C     IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
 232 C             NRINT  - IDENTYFIKATOR PROTOTYPU  INTEGER
 233 C             NRRE   -                          REAL
 234 C             NRBOOL -                          BOOLEAN
 235 C             NRCHR  -                          CHARACTER
 236 C             NRCOR  -                          COROUTINE
 237 C             NRPROC -                          PROCESS
 238 C             NRTEXT -                          STRING (TEXT)
 239 C             NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
 240 C             NATTR  - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
 241 C             NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
 242 C                      REFERENCYJNY)
 243 C             NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
 244 C             NBLUS  -               BLOKU GLOWNEGO UZYTKOWNIKA
 245 C
 246 C             INSYS  - FLAGA SPOSOBU REZERWACJI (PRZEZ  MGETM) PAMIECI
 247 C                      W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
 248 C                      MOWEJ
 249 C             LOCAL  - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
 250 C         BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
 251 C             OWN    - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
 252 C                      POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
 253 C             OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
 254 C                     SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
 255 C
 256 C
 257
 258       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
 259 C
 260 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
 261 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
 262 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W IDICT
 263 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
 264 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
 265 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
 266 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
 267 C                  PROTOTYPU
 268 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
 269 C
 270 C
 271 cdeb       COMMON/NAMES/RESNM,MAINM
 272 cdeb -------------------------------------
 273        common /names/ resnm, mainm, brenam
 274 cdeb ------------------------------------
 275 C   NAZWY ZE SCANNERA
 276 C
 277 C
 278       COMMON  /PREFS/  LPREFS
 279 C
 280 C   **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 281 C    LPREFS  -  OSTATNIO PRZYDZIELONY NUMER W PREFIXSET
 282 C
 283 C
 284 C
 285 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
 286       LOGICAL  ERRFLG
 287       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
 288
 289 c system class prototypes:
 290       common /syspro/ prgraph, prmouse
 291 C
 292 C
 293 C   UTWORZENIE PROTOTYPU BLOKU GLOWNEGO
 294       I=IPMEM(LPMEM)
 295       LINE = IPMEM(I+9)
 296       LASTPR = NBLSYS
 297       NBLUS=INITPR(1,0)
 298 C   USTAWIENIE SL BLOKU GLOWNEGO NA SYSTEMOWY
 299       IPMEM(NBLUS-1) = NBLSYS
 300 cdsw
 301       ipmem(nblus+2) = prgraph
 302       ipmem(prgraph+2) = prmouse
 303       lastpr = prmouse
 304
 305 C   DOLACZENIE NAZWY I ATRYBUTU MAIN
 306       I=MGETM(6,41)+4
 307       IPMEM(I)=VARWD
 308       IPMEM(I+1)=1
 309       CALL MADATR(I,NBLUS,41)
 310       IPMEM(I-3)=NRPROC
 311       IPMEM(I)=IAP(I)
 312       K=IDPUT(MAINM,IPMEM(NBLUS+10))
 313       IPMEM(K+2)=I
 314       CALL DPUTQ(LPMEM,NBLUS)
 315  100  IF(EMPTY) GO TO 300
 316       CALL DGETQ
 317       CALL PROTP1
 318       CALL PROTP2
 319       GO TO 100
 320  300  CONTINUE
 321 C   KONIEC PRZETWARZANIA PROTOTYPOW
 322       IPMEM(NBLSYS+3) = LPREFS
 323 C       ... PRZECHOWANIE INFORMACJI O LICZBIE KLAS
 324       RETURN
 325       END
 326       SUBROUTINE INITMK
 327 C
 328 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 329 C    INICJALIZACJA LOKALNA
 330 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 331 C
 332       IMPLICIT INTEGER(A-Z)
 333 C
 334 C
 335 cdsw ------------------------------------------------
 336       common/signs/nrsig,hliste
 337 cdsw -----------------------------------------------
 338 cdsw  COMMON /SIGNALS/ NRSIG, HLISTE
 339 C
 340 C   NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
 341 C   HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
 342 C
 343 C
 344 C
 345       COMMON  / QUEUE /  BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
 346 cdsw  INTEGER  BQUEUE, EQUEUE
 347       LOGICAL EMPTY
 348 C
 349 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 350 C    ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
 351 C      BQUEUE  -  POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
 352 C      EQUEUE  -  KONIEC      --      --       --      --      --
 353 C      IFIRST  -  PIERWSZY ELEMENT KOLEJKI
 354 C      LAST  -  OSTATNI ELEMENT KOLEJKI
 355 C      EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
 356 C
 357 C
 358       COMMON  /PREFS/  LPREFS
 359 C
 360 C   **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 361 C    LPREFS  -  OSTATNIO PRZYDZIELONY NUMER W PREFIXSET
 362 C
 363 C
 364       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
 365      * MPROCES, MCOR, MERPF, MBLOCK, MHAND
 366      *, MNOTVIR
 367 C
 368 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 369 C   MASKI I WZORCE:
 370 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
 371 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
 372 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
 373 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
 374 C    MASKTP - ZAPRZECZENIE MASKI  MTP
 375 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
 376 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
 377 C    MCOR - WZORZEC DLA COROUTINY (7)
 378 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
 379 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
 380 C    MNOTVIR - MASKA DO KASOWANIA BITU "VIRTUAL"
 381 C
 382 C
 383       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
 384      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
 385 cdsw  INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW, INOUT
 386 C
 387 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 388 C    NULLWD(I)  -  WZORZEc SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
 389 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
 390 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
 391 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
 392 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
 393 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
 394 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
 395 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
 396 C    INOUT  -     --   --   --   ---           ZMIENNEJ INOUT
 397 C
 398 C
 399 C ..... ZMIENNE GLOBALNE
 400 C
 401 C.....
 402       LOGICAL  INSYS,  OWN
 403       COMMON /BLANK/ COM(278),
 404      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 405      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 406      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 407      X        LOCAL , OWN   , OBJECT,
 408      X        IPMEM(5000)
 409 C
 410 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
 411 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
 412 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
 413 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
 414 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
 415 C
 416 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
 417 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
 418 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
 419 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
 420 C
 421 C     IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
 422 C             NRINT  - IDENTYFIKATOR PROTOTYPU  INTEGER
 423 C             NRRE   -                          REAL
 424 C             NRBOOL -                          BOOLEAN
 425 C             NRCHR  -                          CHARACTER
 426 C             NRCOR  -                          COROUTINE
 427 C             NRPROC -                          PROCESS
 428 C             NRTEXT -                          STRING (TEXT)
 429 C             NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
 430 C             NATTR  - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
 431 C             NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
 432 C                      REFERENCYJNY)
 433 C             NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
 434 C             NBLUS  -               BLOKU GLOWNEGO UZYTKOWNIKA
 435 C
 436 C             INSYS  - FLAGA SPOSOBU REZERWACJI (PRZEZ  MGETM) PAMIECI
 437 C                      W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
 438 C                      MOWEJ
 439 C             LOCAL  - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
 440 C                   BYL LOKALNY, 1 - JESLI POCHODZIL Z SL, 0 - GDY Z BL. GL.
 441 C             OWN    - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
 442 C                      POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
 443 C
 444 C
 445 C
 446 C  INICJALIZACJA ZMIENNYCH Z BLOKOW WSPOLNYCH, KTORE NIE SA
 447 C   INICJALIZOWANE W BLOCK DATA
 448 C
 449 C  COMMON /YNIT/
 450 C    NADANIE APETYTOW DLA TYPOW FORMALNYCH
 451 C    DLA TYPOW FORMALNYCH - BIT 14 JEST ZAPALONY
 452        MTP = ISHFT (1,14)
 453        NULLWD(17) = IOR ( NULLWD(17),MTP )
 454        NULLWD(20) = IOR ( NULLWD(20),MTP )
 455 C   DLA POCEDUR/FUNKCJI FORMALNYCH - BIT 15 JEST ZAPALONY
 456        MTP = ISHFT (1,15)
 457        NULLWD(13) = IOR (NULLWD(13),MTP )
 458        NULLWD(14) = IOR (NULLWD(14),MTP )
 459        NULLWD(15) = IOR ( NULLWD(15),MTP )
 460        NULLWD(16) = IOR ( NULLWD(16),MTP )
 461        NULLWD(18) = IOR ( NULLWD(18),MTP )
 462        NULLWD(19) = IOR ( NULLWD(19),MTP )
 463 C
 464 C  COMMON / QUEUE /
 465       BQUEUE=MGETM(LMEM/50,341)
 466       EQUEUE=LPML-1
 467       EMPTY=.TRUE.
 468       LAST=BQUEUE-2
 469       IFIRST=BQUEUE
 470 C
 471 C   COMMON / PREFS /
 472 cdsw      LPREFS=IPMEM(NBLSYS+3)
 473 cdsw       MAXPF=47
 474 C
 475 C   COMMON / MASKS /
 476        MTP=15
 477       MSPR=7
 478       MOTHERS=ISHFT(7,8)
 479       MPAR=ISHFT(15,4)
 480        MASKTP=NOT(MTP)
 481        MNOTVIR=ISHFT(1,11)
 482        MNOTVIR=NOT(MNOTVIR)
 483       MHAND = ISHFT ( 7,8 )
 484       MERPF = ISHFT (1,13)
 485 C
 486 C   COMMON /SIGNALS/
 487       NRSIG = 100
 488 C
 489 C   INICJALIZACJA ZMIENNYCH GLOBALNYCH - CHWILOWA
 490       INSYS=.FALSE.
 491       RETURN
 492       END
 493       SUBROUTINE PROTP1
 494 C
 495 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 496 C   PODPROGRAM SLUZY DO PRZETWARZANIA(OSTATECZNEGO) PROTOTYPU,
 497 C    RAZEM Z PRZETWARZANIEM ZEWNETRZNYM ( WSTEPNYM) JEGO ATRYBUTOW LOKALNYCH.
 498 C   PROTOTYP JEST ZADANY PRZEZ ZMIENNE Z BLOKU /DGLOB/
 499 C   PIERWSZA CZESC PRZETWARZANIA
 500 C  **  **  **  **  **  **  **  **  **  ** *  **  **  **  **  **  **  **
 501 C
 502        IMPLICIT INTEGER (A-Z)
 503 C     INSERTION OF
 504       LOGICAL BTEST
 505 C     BECAUSE OF TYPECONFLICT 03.01.84
 506 C
 507       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
 508 C
 509 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
 510 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
 511 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
 512 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
 513 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
 514 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
 515 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
 516 C                  PROTOTYPU
 517 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
 518 C
 519 C
 520 C ..... ZMIENNE GLOBALNE
 521 C
 522 C.....
 523       LOGICAL  INSYS,  OWN
 524       COMMON /BLANK/ COM(278),
 525      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 526      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 527      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 528      X        LOCAL , OWN   , OBJECT,
 529      X        IPMEM(5000)
 530 C
 531 C
 532 C
 533 C
 534       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
 535      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
 536 cdsw  INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
 537 C
 538 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 539 C    NULLWD(I)  -  WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
 540 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
 541 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
 542 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
 543 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
 544 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
 545 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
 546 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
 547 C    INOUT   -     --   --    --   --          ZMIENNEJ INOUT
 548 C
 549 C
 550       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
 551      * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
 552 C
 553 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 554 C   MASKI I WZORCE:
 555 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
 556 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
 557 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
 558 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
 559 C    MASKTP - ZAPRZECZENIE MASKI  MTP
 560 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
 561 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
 562 C    MCOR - WZORZEC DLA COROUTINY (7)
 563 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
 564 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
 565 C
 566 C
 567 C
 568 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
 569       LOGICAL  ERRFLG
 570       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
 571 C
 572 C
 573 C
 574 C   BUFORY
 575 C
 576 cdeb      COMMON /NAMES/ RESNM, MAINM
 577 cdeb ----------------------------------
 578       common /names/ resnm, mainm,brenam
 579 cdeb --------------------------------
 580 C
 581 C   NAZWY ZE SCANNERA
 582 C
 583 C
 584 C
 585 C
 586 cbc
 587       common /option/ opt
 588 cbc
 589       LOGICAL POM, HAND
 590 C    HAND - CZY TO JEST PROTOTYP HANDLERA
 591 C
 592 C
 593 C   NADANIE WARTOSCI POZOSTALYM ZMIENNYM Z BLOKU /DGLOB/
 594       INDSPR = IPMEM(INDICT)
 595       IHBEG = INDPR+10
 596        I=IPMEM(INDPR)
 597        HAND = .FALSE.
 598        IF ( IAND(I,MOTHERS) .EQ. MHAND ) HAND = .TRUE.
 599        INDPREF = IPMEM(INDPR+21)
 600 C  JESLI BLOK LUB HANDLER - TO ZERO
 601        IF(IAND(I,MTP).EQ.NOTTP.AND.IAND(I,MOTHERS).EQ.MBLOCK.OR.HAND)
 602      * INDPREF = 0
 603 C   .  .  .  .
 604 C   PRZEPISANIE INFORMACJI DLA ANDRZEJA
 605       IPMEM(INDPR+8)=IPMEM(INDSPR-3)
 606       IPMEM(INDPR+9)=IPMEM(INDSPR-2)
 607       IPMEM(INDPR+18)=IPMEM(INDSPR-1)
 608 C   EWENTUALNE POPRAWIENIE SPECYFIKACJI - JESLI PREFIKS
 609 C    NIE JEST REKORDEM
 610       IF(INDPREF.EQ.0) GO TO 50
 611       IF(BTEST(IPMEM(INDPREF),0)) CALL CHECK(INDPR)
 612       GO TO 60
 613 C    JESLI JEST LISTA TAKEN - TO BLAD
 614  50   I=IPMEM(INDSPR+7)
 615       IF(I.EQ.0) GO TO 60
 616       LINE=IPMEM(I+1)
 617       CALL MERR(310,NEMPTY)
 618  60   INSYS=.FALSE.
 619       IF(HAND) GO TO 70
 620 C
 621 C---- ---------------------------------------------------------------
 622 C     PRZETWARZANIE NAGLOWKA
 623       CALL HEADER
 624 C
 625 C  ----------------------------------------------------------------
 626 C   DLA PROCESU - SPRAWDZENIE, CZY NIE MA PF OUTPUT LUB INOUT
 627 C
 628 cbc check if parameters fit into one message
 629 c
 630       I = IAND(IPMEM(INDPR),MTP)
 631       IF(I.NE.MPROCES) GO TO 70
 632 C   PROCES
 633       I = IPMEM(INDPR+3)
 634       K = IPMEM(INDPR+4)
 635       IF(K.EQ.0) GO TO 76
 636       K = K+I-1
 637 cbc check if first parameter is integer
 638       j = ipmem(indpr+22)
 639 80    p = ipmem(j)
 640       tp = iand(ipmem(p), mtp)
 641       if (tp .eq. mproces) goto 81
 642       j = j+1
 643       goto 80
 644 c p = address of first process prototype in prefix sequence
 645 81    l = ipmem(p+4)
 646       p = ipmem(p+21)
 647       if (p .eq. 0) goto 82
 648       if (l .eq. ipmem(p+4)) goto 76
 649       i = i+ipmem(p+4)
 650 82    continue
 651 c i = address of first parameter of process
 652       if (ipmem(ipmem(i)-3) .eq. nrint) goto 75
 653       line = ipmem(indspr+9)
 654       call merr(370, nempty)
 655 75    continue
 656       i = ipmem(indpr+3)
 657 C
 658 cbc
 659       apet = 0
 660 cbc
 661       DO 77 J = I,K
 662       NM = IPMEM(J)
 663 C   NM - IDENTYFIKATOR PARAMETRU
 664 CBC
 665 c   check for formal type
 666       zp = ishft(iand(ipmem(nm), mpar), -4)
 667       if (zp .eq. 1) goto 74
 668 c   check for formal procedure
 669       if (zp .eq. 3) goto 73
 670 c   check if not array
 671       if (ipmem(nm-4) .gt. 0) goto 74
 672       tp = iand(ipmem(ipmem(nm-3)), mtp)
 673 c   check if formal parameter type is process or int,real,char,bool,string
 674 cpat      if (tp .eq. mproces .or. tp .eq. 8 .or. tp .eq. 10 .or.
 675 cpat     *    tp .eq. 12) goto 78
 676       goto 78
 677 74    line = ipmem(indspr+9)
 678       call merr(370 ,nempty)
 679       goto 77
 680 78    continue
 681 c   compute formal parameter appetite in bytes
 682       if (zp .eq. 2) goto 73
 683 c   variable
 684       ap = sapet(0, ipmem(nm-3))
 685       if (ap .eq. 4) ap = 2
 686       goto 72
 687 c   formal procedure or function
 688 73    ap = 3
 689 c   sum up appetites
 690 72    apet = apet + ap
 691 cbc
 692 c      NM = ISHFT(IAND(IPMEM(NM),MPAR),-4)
 693 c      IF(NM.NE.6.AND.NM.NE.9) GO TO 77
 694 c    BLAD - JEST PARAMETR OUTPUT LUB INOUT
 695 c      LINE = IPMEM(INDSPR+9)
 696 c      CALL MERR(370,NEMPTY)
 697 cbc
 698 c
 699   77  CONTINUE
 700 cbc
 701       if (.not. btest(opt, 12)) maxap = 34
 702       if (      btest(opt, 12)) maxap = 15
 703       if (apet .le. maxap) goto 70
 704       line = ipmem(indspr+9)
 705       call merr(370, nempty)
 706       goto 70
 707   76  line = ipmem(indspr+9)
 708       call merr(370, nempty)
 709 c
 710 Cbc
 711 C -----------------------------------------------------------------
 712 C      PRZETWARZANIE WSTEPNE LOKALNYCH PROTOTYPOW -- ETAP I
 713 C
 714 C   POM = FALSE, GDY PRZETWARZAMY TYPY
 715 C   POM = TRUE, GDY PRZETWARZAMY PROCEDURY/FUNKCJE/BLOKI/HANDLERY
 716  70   POM=.FALSE.
 717       I=IPMEM(INDSPR+5)
 718  100  IF(I.EQ.0) GO TO 200
 719       J=IPMEM(I)
 720       J=IPMEM(J)
 721 C   J - IDENTYFIKATOR PROTOTYPU LOKALNEGO W ISMEM
 722 C   NM - NAZWA PROTOTYPU
 723       NM=NEMPTY
 724       IF(IPMEM(J).NE.1 .AND. IPMEM(J).NE.8) NM=IPMEM(J+10)
 725 C   OKRESLENIE RODZAJU PROTOTYPU ( W SENSIE BLOKU INIT)
 726       K=IPMEM(J)
 727 C   WYKRYCIE HANDLERA
 728       IF(K.EQ.8) K=K+15
 729 C      WYKRYCIE BLOKU PREFIKSOWANEGO
 730       IF(K.EQ.1.AND.IPMEM(J+2).NE.0) K=8
 731 C   WYKRYCIE WIRTUALI
 732       LINE = IPMEM(J+9)
 733 C        INSERTION OF LAST STATEMENT DUE TO CORRECTION GIVEN TO ME IN WARSAW
 734 C     IF(BTEST(IPMEM(J+8),15)) K=K+6
 735 C   INSERTION OF THE FOLLOWING STATEMENTS DUE TO CORRECTIONS (SEE ABOVE)
 736       IF (.NOT. BTEST(IPMEM(J+8),15) ) GOTO 110
 737       IF (K.LT.3.OR.K.GT.6) GOTO 120
 738       K=K+6
 739       IF (INDPREF.NE.0) GOTO 110
 740       IF (IAND(IPMEM(INDPR),MTP).NE.NOTTP) GOTO 110
 741       CALL MERR(330,NM)
 742       K=K-6
 743       GOTO 110
 744 120   CALL MERR(329,NM)
 745 C      END OF INSERTION OF STATEMENTS
 746 C   WYWOLANIE INITPR
 747 C     LINE=IPMEM(J+9)
 748 C     DELETION OF PREVIOUS STATEMENT DUE TO CORRECTION
 749 C     K=INITPR(K,NM)
 750 110   K=INITPR(K,NM)
 751 C     INSERTION OF LABEL 110 DUE TO CORRECTIONS
 752 C   W POLU SL PROTOTYPU (W ISMEM) ZAPAMIETUJEMY JEGO IDENTYFIKATOR
 753 C   W IPMEM
 754       IPMEM(J+1) = K
 755 C   PRZEJSCIE DO NASTEPNEGO PROTOTYPU W LISCIE
 756       I=IPMEM(I+1)
 757       GO TO 100
 758 C   PRZETWARZANIE BLOKOW, FUNKCJI I PROCEDUR
 759  200  IF(POM) GO TO 300
 760       POM=.TRUE.
 761       I=IPMEM(INDSPR+6)
 762 C  JESLI PROTOTYP ZAWIERA BLOKI, FUNKCJE LUB PROCEDURY, TO ZMIENIAMY
 763 C   MU KWALIFIKACJE NA PELNA KLASE
 764       IF(I.NE.0) CALL CHECK(INDPR)
 765       GO TO 100
 766 C
 767 C
 768  300  CONTINUE
 769 C
 770 C  ------------------------------------------------------------------------
 771 C    PRZETWARZANIE LISTY SYGNALOW
 772 C
 773       I = IPMEM(INDSPR-4)
 774  350  IF (I.EQ.0) GO TO 500
 775       NM = IPMEM(I+2)
 776       LINE = IPMEM(I+1)
 777       K = IPMEM(I) +12
 778 C   UTWORZENIE PROTOTYPU
 779       K=INITPR(K,NM)
 780 C   ZAPAMIETANIE IDENTYFIKATORA PROTOTYPU SEMANTYCZNEGO
 781       IPMEM(I) = K
 782       I=IPMEM(I+3)
 783       GO TO 350
 784 C
 785 C
 786  500  CONTINUE
 787 C
 788 C    JESLI HANDLER TO KONIEC
 789       IF ( HAND ) GO TO 1100
 790 C  ---  ---  ---  ---  ---  ---  ---  ---  ---  ---  ---  ---   ----  -----
 791 C      PRZETWARZANIE LISTY STALYCH
 792 C
 793       I=IPMEM(INDSPR+4)
 794  600  IF(I.EQ.0) GO TO 700
 795       J=MGETM(6,41)+4
 796 C   J - IDENTYFIKATOR OPISU STALEJ
 797       IPMEM(J)=CONSTWD
 798 C  THIS AND THE NEXT 3 LINES ARE IRRELEVANT            8.5.84
 799 C   SZUKAMY TYPU STALEJ - ZAKLADAMY POPRAWNOSC TYPU
 800 C       ZERO OZNACZA STALA ZDEFINIOWANA PRZEZ WYRAZENIE
 801       IF(IPMEM(I+2).EQ.0)GO TO 630
 802 C
 803 C     TYLKO DLA STALEJ TEKSTOWEJ :
 804       K=MEMBER(IPMEM(I+2),IPMEM(NBLSYS+10))
 805 C LAST STATEMENT CHANGED TO COMMENT DUE TO CORRECTIONS FROM WARSAW   8.5.84
 806 C THIS AND THE NEXT 2 LINES ARE IRRELEVANT 8.5.84
 807       IPMEM(J-3)=IPMEM(K+2)
 808 C LAST STATEMENT CHANGED TO COMMENT DUE TO CORRECTIONS FROM WARSAW  8.5.84
 809 C   PRZEPISANIE ADRESU STALEJ
 810  630  IPMEM(J-1)=IPMEM(I+4)
 811 C   WSTAWIENIE STALEJ DO ZBIORU IDENTYFIKATOROW
 812       LINE=IPMEM(I+1)
 813       K=IDPUT(IPMEM(I),IPMEM(IHBEG))
 814       IF(K.EQ.0) GO TO 650
 815 C   NIE MA PODWOJNEJ DEKLARACJI
 816       IPMEM(K+2) = J
 817 C   USTAWINIE BITU CLOSE
 818       IPMEM(K+1) = 1
 819 C   PRZEJSCIE DO NASTEPNEGO ELEMENTU LISTY
 820  650   I=IPMEM(I+5)
 821       GO TO 600
 822 C
 823 C
 824  700  CONTINUE
 825 C
 826 C  ----  ----  ----  ----  ----  ----  ----  ----  ----  ----   ----  ----
 827 C    PRZETWARZANIE LISTY ZMIENNYCH
 828 C
 829 C
 830       I=IPMEM(INDSPR+3)
 831  800  IF(I.EQ.0) GO TO 1000
 832       J=MGETM(6,41)+4
 833 C   J- IDENTYFIKATOR OPISU ZMIENNEJ
 834       IPMEM(J) = VARWD
 835 C   WSTAWIENIE DO ZBIORU IDENTYFIKATOROW
 836       LINE=IPMEM(I+1)
 837       K=IDPUT(IPMEM(I),IPMEM(IHBEG))
 838       IF(K.EQ.0) GO TO 900
 839 C   NIE MA PODWOJNEJ DEKLARACJI
 840       IPMEM(K+2)=J
 841 C   WSTAWIENIE DO LISTY ATRYBUTOW
 842  900  CALL MADATR(J,INDPR,41)
 843 C   ZAPAMIETANIE 1 W POLU USED - DLA AIL
 844       IPMEM(J+1)=1
 845 C   ZAMIAST NAZWY ZMIENNEJ(W ISMEM) ZAPAMIETUJEMY JEJ IDENTYFIKATOR W IPMEM
 846       IPMEM(I)=J
 847 C   PRZEJSCIE DO NASTEPNEGO ELEMENTU LISTY
 848       I=IPMEM(I+4)
 849       GO TO 800
 850 C
 851 C
 852  1000 CONTINUE
 853 C
 854 C
 855 C  DOLACZENIE DO ZBIORU IDENTYFIKATOROW ID. RESULT DLA FUNKCJI
 856       I=ISHFT(IAND(IPMEM(INDPR),MOTHERS),-8)
 857       IF(I.LT.2.OR.I.GT.3) GO TO 1050
 858       J=MEMBER(RESNM,IPMEM(IHBEG))
 859       IF(J.NE.0) GO TO 1050
 860       J=INSERT(RESNM,IPMEM(IHBEG),41)
 861       IPMEM(J+2)= IPMEM(INDPR-5)
 862  1050 CONTINUE
 863 C
 864 C
 865 C---- ---- ---- ----- ---- ----- ----- ---- ----- ----- ----- ----- --
 866 C   TWORZENIE ZBIORU IDENTYFIKATOROW
 867 C
 868 C   JESLI JEST PREFIKS, TO UZUPELNIAMY ZBIOR IDENTYFIKATOROW
 869       IF(INDPREF.EQ.0) GO TO 1100
 870       CALL MERGEID
 871 C
 872 C
 873  1100 CONTINUE
 874       RETURN
 875       END
 876       SUBROUTINE PROTP2
 877 C
 878 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 879 C   PODPROGRAM SLUZY DO PRZETWARZANIA(OSTATECZNEGO) PROTOTYPU,
 880 C    RAZEM Z PRZETWARZANIEM ZEWNETRZNYM ( WSTEPNYM) JEGO ATRYBUTOW LOKALNYCH.
 881 C   PROTOTYP JEST ZADANY PRZEZ ZMIENNE Z BLOKU /DGLOB/
 882 C   DRUGA CZESC PRZETWARZANIA
 883 C  **  **  **  **  **  **  **  **  **  ** *  **  **  **  **  **  **  **
 884 C
 885        IMPLICIT INTEGER (A-Z)
 886       LOGICAL POM
 887 C     INSERTION OF
 888       LOGICAL BTEST
 889 C     BECAUSE OF TYPECONFLICT 03.01.84
 890 C
 891       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
 892 C
 893 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
 894 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
 895 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
 896 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
 897 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
 898 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
 899 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
 900 C                  PROTOTYPU
 901 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
 902 C
 903 C
 904 C
 905 C
 906       COMMON  / VIRT /  LISTVB,LISTVE,OWNVIR
 907       LOGICAL OWNVIR
 908 C
 909 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
 910 C    ROBOCZY BLOK WSPOLNY.
 911 C    LISTVB  -  POCZATEK ROBOCZEJ LISTY VIRTLIST
 912 C    LISTVE  -  KONIEC ROBOCZEJ LISTY  VIRTLIST
 913 C    OWNVIR = TRUE, JESLI W PROTOTYPIE BYLY WLASNE VIRTUALE
 914 C
 915 C ..... ZMIENNE GLOBALNE
 916 C
 917 C.....
 918       LOGICAL  INSYS,  OWN
 919       COMMON /BLANK/ COM(278),
 920      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 921      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 922      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 923      X        LOCAL , OWN   , OBJECT,
 924      X        IPMEM(5000)
 925 C
 926 C
 927 C
 928 C.....
 929 C     KOMUNIKACJA Z PROCEDURA MEMPRF
 930       COMMON /MEM/  NME, NH
 931 C            NME - SZUKANA NAZWA
 932 C            NH - JEJ HASZ
 933 C
 934 C
 935 cdsw  COMMON /SIGNALS/ NRSIG, HLISTE
 936 cdsw     -------------------------------------------------
 937       common /signs/ nrsig, hliste
 938 cdsw     -------------------------------------------------
 939 C
 940 C   NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
 941 C   HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
 942 C
 943 C
 944 C
 945       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
 946      * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
 947 C
 948 C
 949 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
 950       LOGICAL  ERRFLG
 951       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7) ,JUNK(260)
 952 C
 953 C
 954 C
 955 C  ----  ------  ------  ------  -------  -------  -------  ------------
 956 C
 957 C   WSTEPNE PRZETWARZANIE PROTOTYPOW LOKALNYCH  --  ETAP  II
 958 C
 959 C
 960 C    -----   ------   ------  -----  -----  -----  -----  -----  -----  -----
 961 C    PRZETWARZANIE SYGNALOW
 962 C
 963       LN = 0
 964       I=IPMEM(INDSPR-4)
 965  100  IF ( I.EQ.0 ) GO TO 500
 966       CALL SIGNAL(I)
 967       I = IPMEM(I+3)
 968       GO TO 100
 969 C
 970 C
 971  500  CONTINUE
 972 C
 973 C   ------    ------    ------    ------    ------    -------    ------  ----
 974 C   PRZEPISANIE LISTY VIRTLIST Z PREFIKSU
 975 C
 976        LISTVE=0
 977       LISTVB=LPML
 978       IF(INDPREF.EQ.0) GO TO 1200
 979       I=IPMEM(INDPREF+25)
 980 C   I - DLUGOSC LISTY WIRTLIST Z PREFIKSU
 981       IF(I.EQ.0) GO TO 1200
 982       IF(I.LT.0) I=-I
 983 C   JEST LISTY WIRTLIST W PREFIKSIE
 984       INSYS=.TRUE.
 985       LISTVB=MGETM(I,41)
 986       LISTVE=LPML-1
 987       INSYS=.FALSE.
 988 C   PRZEPISYWANIE
 989       K=IPMEM(INDPREF+24)
 990 C   K - POCZATEK LISTY VIRTLIST W PREFIKSIE
 991       DO 1111 J=1,I
 992       IJ1 = LISTVB+J-1
 993       IJ2 = K+J-1
 994  1111 IPMEM(IJ1) = IPMEM(IJ2)
 995  1200 OWNVIR=.FALSE.
 996 C   PUSTA LISTA LOKALNYCH HANDLEROW
 997        HLISTE = 0
 998 C   PRZETWARZANIE WSZYSTKICH PROTOTYP6W
 999        POM=.FALSE.
1000       I=IPMEM(INDSPR+5)
1001 C   ZACZYNAMY OD TYPOW
1002  1300 IF(I.EQ.0) GO TO 1400
1003       CALL BEGPROT(IPMEM(I))
1004       I=IPMEM(I+1)
1005       GO TO 1300
1006  1400 IF(POM) GO TO 1600
1007       POM=.TRUE.
1008 C   PROCEDURY, FUNKCJE I BLOKI
1009       I=IPMEM(INDSPR+6)
1010         GO TO 1300
1011 C
1012 1600  CONTINUE
1013 C   JESLI HANDLER TO KONIEC
1014       IF ( IAND(IPMEM(INDPR),MOTHERS).EQ.MHAND) GO TO 4000
1015 C
1016 C   UTUPELNIENIE INFORMACJI I WIRTUALACH
1017       IF(OWNVIR) GO TO 1700
1018 C   NIE BYLO WLASNYCH WIRTUALI
1019       IF(INDPREF.EQ.0) GO TO 1900
1020 C   DOWIAZUJEMY SIE DO LISTY VIRTLIST Z PREFIKSU, ZMIENIAJAC DLUGOSC NA UJEMNA
1021       IPMEM(INDPR+24) = IPMEM(INDPREF+24)
1022       IPMEM(INDPR+25) = -IPMEM(INDPREF+25)
1023       GO TO 1900
1024 C   BYLY WLSNE WIRTUALE - PRZEPISUJEMY LISTE VIRTLIST
1025  1700 I=LISTVE-LISTVB+1
1026       K = MGETM(I,41)
1027       IPMEM(INDPR+24) = K
1028       DO 1777 J=1,I
1029       IJ1=K+J-1
1030       IJ2=LISTVB+J-1
1031  1777 IPMEM(IJ1) = IPMEM(IJ2)
1032       IPMEM(INDPR+25) = I
1033 C   ZWALNIAMY PAMIEC PRZEZNACZONA NA VIRTLIST W CZESCI SYSTEMOWEJ
1034  1900 CONTINUE
1035        LPML=LISTVB
1036 C
1037 C
1038  2000 CONTINUE
1039 C
1040 C  ----  -----   -----  --------   ----------   -------  ----  -----   -------
1041 C        NADAWANIE TYPOW ZMIENNYM
1042 C
1043       I=IPMEM(INDSPR+3)
1044       IF(I.EQ.0) GO TO 2400
1045  2100 J=IPMEM(I)
1046 C  J - IDENTYFIKATOR OPISU ZMIENNEJ W IPMEM
1047       NM=IPMEM(I+2)
1048 C   NM - NAZWA TYPU
1049       LINE=IPMEM(I+1)
1050        K=IFTYPE(NM)
1051       IPMEM(J-3) = K
1052       IPMEM(J-4) = IPMEM(I+3)
1053 C   NADANIE APETYTU ZMIENNEJ
1054       IPMEM(J) = IAP(J)
1055 C   JESLI TO JEST TYP FORMALNY, TO POPRAWIAMY SLOWO ZEROWE OPISU ZMIENNEJ
1056       IF(IAND(IPMEM(K),MTP).NE.6) GO TO 2350
1057       IPMEM(J) = IOR(IPMEM(J),ISHFT(1,12))
1058 C    JESLI TYP FORMALNY JEST NIELOKALNY, TO ZMIENIAMY RODZAJ PROTOTYPU
1059 C    NA KLASE PELNA
1060       IF(LOCAL.EQ.2) GO TO 2350
1061       CALL CHECK(INDPR)
1062  2350  I=IPMEM(I+4)
1063       IF(I.NE.0) GO TO 2100
1064 C
1065 C
1066  2400 CONTINUE
1067 C
1068 C  ----  ------  -----  ---  ----  ------  -----   ------  ----------
1069 C      SPRAWDZENIE POPRAWNOSCI LIST HIDDEN I CLOSE I UZUPELNIENIE INFORMACJI
1070 C
1071 C   JESLI PROTOTYP NIE JEST KLASA TO PRZECHODZIMY DALEJ
1072       IF(IPMEM(INDSPR).NE.2.AND.IPMEM(INDSPR).NE.7) GO TO 3000
1073       I=IPMEM(INDSPR+12)
1074 C   K = 0 -- CLOSE, K=1 -- HIDDEN
1075        K=1
1076  2500 IF(I.EQ.0) GO TO 2700
1077       NME=IPMEM(I)
1078       LN=LINE
1079       LINE=IPMEM(I+1)
1080 C  NME - NAZWA W LISCIE HIDDEN(CLOSE)
1081       NH=IAND(ISHFT(NME,-1),7)+1
1082       J=MEMPRF(INDPR)
1083       IF(J.EQ.0) GO TO 2600
1084 C  NAZWA JEST ZADEKLAROWANA
1085 C   JESLI NAZWA JEST HIDDEN LUB NOT TAKEN, TO BLAD
1086       NM=IPMEM(J+1)
1087       IF(BTEST(NM,2)) GO TO 2660
1088       IF(OWN) GO TO 2550
1089       IF(BTEST(NM,1)) GO TO 2650
1090 C   NAZWA POCHODZI Z PREFIKSU
1091       NM=INSERT(NME,IPMEM(IHBEG),41)
1092       IPMEM(NM+2) = IPMEM(J+2)
1093       IPMEM(NM+1)= IPMEM(J+1)
1094       J=NM
1095 C   USTAWIAMY BIT K W ELEMENCIE LISTY HASHU
1096  2550 IPMEM(J+1) = IOR(IPMEM(J+1),ISHFT(1,K))
1097 C   PRZECHODZIMY DO NASTEPNEGO ELEMENTU LISTY
1098  2560 I=IPMEM(I+2)
1099       GO TO 2500
1100 C   NAZWA NIEZADEKLAROWANA
1101  2600 J=INSERT(NME,IPMEM(IHBEG),41)
1102       CALL MERR(305,NME)
1103       GO TO 2550
1104 C   NAZWA HIDDEN - NIEDOSTEPNA
1105  2650 CALL MERR(319,NME)
1106       GO TO 2560
1107 C   NAZWA NOT TAKEN - NIEDOSTEPNA
1108  2660 CALL MERR(320,NME)
1109       GO TO 2560
1110  2700 IF(K.EQ.0) GO TO 3000
1111       K=0
1112       I=IPMEM(INDSPR+13)
1113       GO TO 2500
1114 C
1115 C
1116  3000 CONTINUE
1117 C
1118 C----   ------   ------  ------  -------  -------  --------  -------
1119 C    KOMPATYBILNOSC VIRTUALI
1120 C
1121       IF(.NOT.BTEST(IPMEM(INDPR),11)) GO TO 4000
1122 C   PROTOTYP JEST VIRTUALEM
1123 C   SPRAWDZAMY, CZY ISTNIEJE WYZSZY VIRTUAL
1124       LINE=LN
1125       IF(IPMEM(INDPR+26).EQ.0) GO TO 4000
1126       CALL VIRTCOM
1127 C
1128 C
1129  4000 CONTINUE
1130 C
1131 C  ------  ------  ------   ------  ------  ------  -------------  ---
1132 C     ZAKONCZENIE - ZAPAMIETUJEMY IDENTYFIKATOR PROTOTYPU W SLOWNIKU
1133 C    ISDICT
1134 C
1135       IPMEM(INDICT) = INDPR
1136 C
1137       RETURN
1138       END
1139       INTEGER FUNCTION IAP(IND)
1140 C
1141 C   WYLICZA APETYT ATRYBUTU IND :
1142 C           0  (00) - INTEGER,BOOLEAN,CHAR,STRING
1143 C           1  (01) - REAL, FORMAL TYPE
1144 C           2  (10) - FORMAL PROCEDURE,FORMAL FUNCTION
1145 C           3  (11) - REFERENCE
1146 C   W WYNIKU ZMIENIA SLOWO ZEROWE
1147 C
1148       IMPLICIT INTEGER(A-Z)
1149 C
1150 C.....
1151       LOGICAL  INSYS,  OWN
1152       COMMON /BLANK/ COM(278),
1153      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1154      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1155      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1156      X        LOCAL , OWN   , OBJECT,
1157      X        IPMEM(5000)
1158 C
1159 C
1160       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
1161      * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
1162 C
1163 C
1164       J=IPMEM(IND-3)
1165 C   J - IDENT TYPU
1166       I=IAND(IPMEM(J),MTP)
1167       IAP=0
1168       IF(I.LT.8.OR.I.EQ.11) IAP = 3
1169       IF(J.EQ.NRRE) IAP=1
1170       IF(IPMEM(IND-4).NE.0)  IAP=3
1171 C   ZMIANA SLOWA ZEROWEGO
1172       IAP=IOR(IPMEM(IND),ISHFT(IAP,14))
1173       RETURN
1174       END
1175       SUBROUTINE BEGPROT(NRSDIC)
1176 C
1177 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1178 C   PODPROGRAM SLUZY DO WSTEPNEGO PRZETWARZANIA PROTOTYPOW LOKALNYCH
1179 C   W PROTOTYPIE IDENTYFIKOWANYM PRZEZ  INDPR.
1180 C   DLA KAZDEGO PROTOTYPU:
1181 C        - ANALIZUJE JEGO PREFIKS
1182 C        - UZUPELNIA INFORMACJE O RODZAJU PROTOTYPU
1183 C        - JESLI PROTOTYP JEST PROCEDURA LUB FUNKCJA VIRTUALNA, TO SZUKA
1184 C          BEZPOSREDNIO WYZSZEGO VIRTUALA I WSTAWIA IDENTYFIKATOR PROTOTYPU
1185 C          DO LISTY VIRTLIST PROTOTYPU OBEJMUJACEGO.
1186 C        - DLA FUNKCJI  --  ZNAJDUJE JEJ TYP.
1187 C   PODPROGRAM WSTAWIA PARE  ( NRSDIC, IDENT. W IPMEM)  DO KOLEJKI
1188 C    PROTOTYPOW.
1189 C   NRSDIC - INDEKS PROTOTYPU W IPMEM.
1190 C   W  IPMEM  W POLU  SL  ZAPAMIETANY JEST IDENTYFIKATOR TEGO PROTOTYPU W
1191 C      IPMEM.
1192 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1193 C
1194 C
1195       IMPLICIT INTEGER(A-Z)
1196 C
1197 C
1198       LOGICAL IFCLASS,BPREF,ONLY
1199 C
1200 C     INSERTION OF
1201       LOGICAL BTEST
1202 C     BECAUSE OF TYPECONFLICT 03.01.84
1203 C
1204 C
1205 C.....
1206       LOGICAL  INSYS,  OWN
1207       COMMON /BLANK/ COM(278),
1208      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1209      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1210      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1211      X        LOCAL , OWN   , OBJECT,
1212      X        IPMEM(5000)
1213 C
1214 C
1215       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
1216 C
1217 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
1218 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
1219 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
1220 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
1221 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
1222 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
1223 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
1224 C                  PROTOTYPU
1225 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
1226 C
1227 C
1228       COMMON  / VIRT /  LISTVB,LISTVE,OWNVIR
1229       LOGICAL OWNVIR
1230 C
1231 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
1232 C    ROBOCZY BLOK WSPOLNY.
1233 C    LISTVB  -  POCZATEK ROBOCZEJ LISTY VIRTLIST
1234 C    LISTVE  -  KONIEC ROBOCZEJ LISTY  VIRTLIST
1235 C    OWNVIR = TRUE, JESLI W PROTOTYPIE BYLY WLASNE VIRTUALE
1236 C
1237 C
1238       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
1239      * MPROCES, MCOR, MERPF, MBLOCK, MHAND
1240      *, MNOTVIR
1241 C
1242 C
1243       COMMON  /PREFS/  LPREFS
1244 C
1245 C   **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
1246 C    LPREFS  -  OSTATNIO PRZYDZIELONY NUMER W PREFIXSET
1247 C
1248 C
1249 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
1250       LOGICAL  ERRFLG
1251       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
1252 C
1253 C
1254       COMMON / DONLY / IONLY,ONIL
1255       LOGICAL ONIL
1256 C
1257 C  ROBOCZY BLOK,UZYWANY PRZY TWORZENIU ZBIORU IDENTYFIKAROROW
1258 C   IONLY  - POCZATEK LISTY TAKEN
1259 C   ONIL - TRUE, GDY JEST TAKEN NONE
1260 C
1261 C
1262 C
1263 C
1264 C   *   *   *   *   *   *   *   *   *   *   *   *   *
1265 C   NADANIE WARTOSCI ZMIENNYM.
1266 C   IDSMEM - IDENTYFIKATOR W IPMEM PRZETWARZANEGO PROTOTYPU.
1267 C   IDPMEM - IDENTYFIKATOR PROTOTYPU W IPMEM.
1268 C   ISYS = 1  DLA COROUTINE, ISYS = 2 DLA PROCESS.
1269 C  LINE - NR LINII DEKLARACJI PROTOTYPU.
1270 C   *   *   *   *   *   *   *   *   *   *   *   *   *
1271 C
1272 C
1273       IDSMEM = IPMEM(NRSDIC)
1274       IDPMEM = IPMEM(IDSMEM+1)
1275 C   JESLI HANDLER - TO DO PRZETWARZANIE HANDLERA
1276       IF(IPMEM(IDSMEM).EQ.8) GO TO 2500
1277       ISYS=IAND(IPMEM(IDSMEM+8),MSPR)
1278       LINE = IPMEM(IDSMEM+9)
1279 C
1280 C
1281 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1282 C    PRZETWARZANIE PREFIKSU
1283 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1284 C
1285 C   I - NAZWA PREFIKSU
1286       I = IPMEM(IDSMEM+2)
1287 C        IDPR - BEDZIE IDENTYFIKATOREM PREFIKSU
1288       IDPR = 0
1289       IF( I.EQ.0) GO TO 500
1290 C         JEST PREFIKS
1291       IDPR = MEMSL(I,INDPR)
1292       IF(IDPR.NE.0) GO TO 50
1293 C        PREFIKS JEST NIEZADEKLAROWANY
1294       CALL MERR(308,I)
1295       GO TO 500
1296 C   BADAMY, CZY PREFIKS JEST DOSTEPNY
1297  50   IRODZ=IPMEM(IDPR+1)
1298       IF(BTEST(IRODZ,2)) GO TO 60
1299       IF(.NOT.BTEST(IRODZ,1)  .OR.OWN)GO TO 100
1300 C   NAZWA PROFIKSU JEST HIDDEN - BLAD
1301       CALL MERR(322,I)
1302       GO TO 150
1303 C   NAZWA PREFIKSU JEST NOT-TAKEN
1304  60   CALL MERR(323,I)
1305       GO TO 150
1306 C        BADAMY, CZY PREFIKS JEST KLASA
1307  100  IDPR = IPMEM(IDPR+2)
1308       IF(IDPR.EQ.NRUNIV) GO TO 150
1309 C        IRODZ - CZESC T W SLOWIE ZEROWYM PREFIKSU
1310       IRODZ=IAND(IPMEM(IDPR),MTP)
1311       IF(IFCLASS(IRODZ)) GO TO 200
1312 C        PREFIKS NIE JEST KLASA
1313       CALL MERR(301,I)
1314  150  IDPR=0
1315       GO TO 210
1316 C
1317 C   PREFIKS JEST POPRAWNY
1318  200  CONTINUE
1319 C   JESLI PREFIKS MIAL BLEDNA LISTE PF, TO POPRAWIAMY
1320 C    SLOWO ZEROWE
1321       IF(IAND(IPMEM(IDPR),MERPF).EQ.0) GO TO 250
1322 C   POPRAWIAMY SLOWO ZEROWE
1323  210  IPMEM(IDPMEM) = IOR(IPMEM(IDPMEM),MERPF)
1324  250  CONTINUE
1325       IF(IDPR.EQ.0) GO TO 500
1326 C        WSTAWIAMY IDENTYFIKATOR BEZPOSREDMIEGO PREFIKSU DO OPISU PROTOTYPU
1327        IPMEM(IDPMEM+21) = IDPR
1328 C        PRZEPISANIE LISTY PREFIKSLIST Z PREFIKSU I DOLACZENIE SIEBIE
1329 C        NA KONCU LISTY
1330 C        I - DLUGOSC LISTY PREFIKSLIST Z PREFIKSU - 1
1331 C        J - POCZATEK PREFIXLIST Z PREFIKSU
1332 C        J1 - POCZATEK TWORZONEJ LISTY PREFIKSLIST
1333         I=IPMEM(IDPR+23)
1334       J = IPMEM(IDPR+22)
1335       J1 = MGETM(I+1,41)
1336       DO 222 II=1,I
1337       IJ1=J1+II-1
1338       IJ2=J+II-1
1339  222  IPMEM(IJ1) = IPMEM(IJ2)
1340 C  DOLOCZAMY SIEBIE DO LISTY PREFIXLIST I WSTAWIAMY PREFIXLIST DO
1341 C      OPISU PROTOTYPU
1342       IJ1=J1+I
1343       IPMEM(IJ1) = IDPMEM
1344       IPMEM(IDPMEM+22)=J1
1345       IPMEM(IDPMEM+23) = I+1
1346 C
1347 C  SPRAWDZENIE POPRAWNOSCI PREFIKSOW SYSTEMOWYCH
1348 C  TWORZENIE PREFIXSET
1349 C
1350 C
1351 C
1352 C  I=1  JESLI PREFIKS JEST COROUTINA
1353 C  I=2  JESLI PREFIKS JEST PRECESEM
1354 C  I=0  W PRZECIWNYM PRZYPADKU
1355       I=0
1356       IF(BPREF(IDPR,IPMEM(NRCOR-6))) I=1
1357       IF(BPREF(IDPR,IPMEM(NRPROC-6))) I=2
1358 C  JESLI PROTOTYP NIE JEST KLASA, TO PRZECHODZIMY DO BADANIA POPRAWNOSCI
1359 C     PREFIKSOWANIA
1360       J=IAND(IPMEM(IDPMEM),MTP)
1361       IF(J.EQ.NOTTP) GO TO 800
1362 C  PRZEPISANIE PREFIXSET Z PREFIKSU
1363       IPMEM(IDPMEM-3) = IPMEM(IDPR-3)
1364       IPMEM(IDPMEM-4) = IPMEM(IDPR-4)
1365       IPMEM(IDPMEM-5) = IPMEM(IDPR-5)
1366 C   ROZPOZNAMIE RODZAJU PROTOTYPU
1367       IF(ISYS.LT.I) ISYS=I
1368  300  IF(ISYS.EQ.0) GO TO 400
1369 C
1370 C   PROTOTYP JEST COROUTINA LUB PROCESEM
1371       CALL CHECK(INDPR)
1372 C  USTAWIAMY ODPOWIEDNIE BITY W PREFIXSET
1373       I=IPMEM(IDPMEM)
1374       CALL MSETB(IDPMEM,IPMEM(NRCOR-6))
1375       IF(ISYS.NE.2) GO TO 350
1376       CALL MSETB(IDPMEM,IPMEM(NRPROC-6))
1377 C  POPRAWIAMY SLOWO ZEROWE PROTOTYPU - TO JEST PROCES
1378       IPMEM(IDPMEM) = IOR(IAND(I,MASKTP),MPROCES)
1379       GO TO 400
1380 C  POPRAWIAMY SLOWO ZEROWE - TO JEST COROUTINA
1381  350  IPMEM(IDPMEM) = IOR(IAND(I,MASKTP),MCOR)
1382 C  PRZYDZIELENIE NUMERU W SENSIE PREFIXSET
1383  400  LPREFS = LPREFS+1
1384       CALL MSETB(IDPMEM,LPREFS)
1385       IPMEM(IDPMEM-6) = LPREFS
1386 C   JESLI KLASA MA BLEDNA LISTE PF, TO POPRAWIAMY NA PELNA
1387       IF(IAND(IPMEM(IDPMEM),MERPF).NE.0)
1388      * CALL CHECK(IDPMEM)
1389 C   JESLI W KLASIE BYLY INSTRUKCJE, TO POPRAWIAMY NA KLASE PELNA
1390       IF(BTEST(IPMEM(IDSMEM+8),13))  CALL CHECK(IDPMEM)
1391       GO TO 1000
1392 C
1393 C  NIE BYLO PREFIKSU, LUB BYL BLEDNY PREFIKS.
1394 C  JESLI PROTOTYP JEST BLOKIEM, TO KONCZYMY PRZETWARZANIE PREFIKSOW
1395  500  CONTINUE
1396       J1 = IPMEM(IDPMEM)
1397       IF(IAND(J1,MTP).EQ.NOTTP.AND.IAND(J1,MOTHERS).EQ.MBLOCK)
1398      *   GO TO 1000
1399 C  DOLOCZAMY SIEBIE JAKO JEDYNY ELEMENT LISTY PREFIKSOW
1400       J = MGETM(1,41)
1401       IPMEM(J) = IDPMEM
1402       IPMEM(IDPMEM+22) = J
1403       IPMEM(IDPMEM+23) = 1
1404 C  JESLI PROTOTYP NIE JEST KLASA, TO KONIEC PRZETWARZANIA PREFIKSOW
1405        IF(IAND(J1,MTP).EQ.NOTTP) GO TO 1000
1406 C  USTAWIAMY BIT 2 W PREFIKSSET NA 1 I PRZECHODZIMY DO USTALENIA RODZAJU
1407 C   KLASY
1408       CALL MSETB(IDPMEM,2)
1409       GO TO 300
1410 C
1411 C  SPRAWDZENIE POPRAWNOSCI PREFIKSOW SYSTEMOWYCH
1412  800  IF(I.EQ.0) GO TO 1000
1413 C   COROUTINE LUB PROCES NIE PREFIKSUJE KLASY
1414       CALL MERR(303,IPMEM(IDSMEM+2))
1415 C
1416 C
1417 C --- --- --- --- --- --- --- --- --- --- --- ---
1418 C     PRZETWARZANIE INFORMACJI O WIRTUALACH
1419 C
1420  1000 CONTINUE
1421 C
1422 C  JESLI TO NIE JEST WIRTUAL, TO PRZECHODZIMY DALEJ
1423       IF(.NOT.BTEST(IPMEM(IDSMEM+8),15)) GO TO 2000
1424 C   TO JEST WIRTUAL.
1425 C   JESLI PROTOTYP OBEJMUJACY JEST BLOKIEM NIEPREFIKSOWANYM, TO KASUJEMY
1426 C      WIRTUALE
1427        IF(IPMEM(INDPR).NE.1) GO TO 1001
1428        IPMEM(IDPMEM)=IAND(IPMEM(IDPMEM),MNOTVIR)
1429        GO TO 2000
1430 C
1431 C  BIT NR 11 W SLOWIE ZEROWYM JEST JUZ USTAWIONY PRZEZ PODPROGRAM INITPR
1432 C  OWNVIR = .TRUE., JESLI W PROTOTYPIE INDPR SA WLASNE WIRTUALE
1433 C
1434  1001 OWNVIR=.TRUE.
1435 C   CZUKA,Y BEZPOSREDNIO WYZSZEGO VIRTUALA
1436        IF(INDPREF.EQ.0) GO TO 1300
1437 C  PROTOTYP OBEJMUJACY MA PREFIKS
1438 C  I - NAZWA VIRTUALA
1439       I=IPMEM(IDSMEM+10)
1440 C   SPRAWDZAMY,CZY WIRTUAL JEST NA LISCIE TAKEN Z PREFIKSU
1441       IONLY=IPMEM(INDSPR+7)
1442       ONIL=BTEST(IPMEM(INDSPR+8),14)
1443       IF(.NOT.ONLY(I)) GO TO 1300
1444       J=MEMSL(I,INDPREF)
1445       IF(J.EQ.0) GO TO 1300
1446       IF(LOCAL.NE.2.OR.BTEST(IPMEM(J+1),1)) GO TO 1300
1447       IF(BTEST(IPMEM(J+1),2)) GO TO 1300
1448       J = IPMEM(J+2)
1449 C   SPRAWDZAMY,CZY TO JEST WIRTUAL
1450       IF(.NOT.BTEST(IPMEM(J),11))  GO TO 1300
1451 C   ZNALEZLISMY BEZPOSREDNIO WYZSZY WIRTUAL
1452 C  J - IDENTYFIKATOR BEZPOSREDNIO WYZSZEGO WIRTUALA
1453 C  I  - NUMER WIRTUALNY
1454       I = IPMEM(J+27)
1455       IPMEM(IDPMEM+26) = J
1456       IPMEM(IDPMEM+27) = I
1457 C  WSTAWIAMY WIRTUAL DO VIRTLIST (ROBOCZEJ) PROTOTYPU OBEJMUJACEGO
1458       IJ1=LISTVB+I
1459       IPMEM(IJ1) = IDPMEM
1460       GO TO 2000
1461 C
1462 C  NIE BYLO BEZPOSREDNIO WYZSZEGO WIRTUALA
1463  1300 CONTINUE
1464       INSYS = .TRUE.
1465       LISTVE = MGETM(1,41)
1466 C  DOKLADAMY NUMER WIRTUALNY
1467       IPMEM(IDPMEM+27) = LISTVE-LISTVB
1468       INSYS=.FALSE.
1469       IPMEM(LISTVE)=IDPMEM
1470 C
1471 C
1472 C -- -- -- -- -- -- -- -- --- -- -- -- --- -- --
1473 C     DLA FUNKCJI  --  PRZETWARZANIE JEJ TYPU
1474 C
1475  2000 CONTINUE
1476 C
1477 C  BADAMY, CZY PROTOTYP JEST FUNKCJA
1478       I = ISHFT(IAND(IPMEM(IDPMEM),MOTHERS),-8)
1479       IF(I.NE.2) GO TO 3000
1480 C   SZUKAMY TYPU;  J - NAZWA TYPU
1481       J = IPMEM(IDSMEM+12)
1482       I=IFTYPE(J)
1483 C  SPRAWDZAMY, CZY TO JEST TYP FORMALNY
1484 C  I - IDENTYFIKATOR TYPU
1485       IF(IAND(IPMEM(I),MTP).NE.6) GO TO 2100
1486 C  TO JEST TYP FORMALBY - ZMIANA SLOWA ZEROWEGO W PROTOTYPIE FUNKCJI
1487       IPMEM(IDPMEM)= IOR(IPMEM(IDPMEM),ISHFT(1,12))
1488 C  WSTAWIENIE TYPU
1489  2100 IPMEM(IDPMEM-3) = I
1490       IPMEM(IDPMEM-4) = IPMEM(IDSMEM+13)
1491       GO TO 3000
1492 C
1493 C
1494  2500 CONTINUE
1495 C
1496 C  ---  ----  ----  ----  ----   ----  ----  ----  ----  ----  ----  ----  ----
1497 C  PRZETWARZANIE HANDLERA
1498 C
1499       CALL HANDLER ( IDSMEM )
1500 C
1501 C
1502 C
1503 C  ----  ----  ----  ----  ----  ----  ----  ----
1504 C     WSTAWINEI PARY  (NRSDIC,IDPMEM)  DO KOLEJKI PROTOTYPIOW
1505 C
1506  3000 CONTINUE
1507       CALL DPUTQ(NRSDIC,IDPMEM)
1508       RETURN
1509       END
1510       LOGICAL FUNCTION IFCLASS(IX)
1511
1512 C  *****************
1513 C   FUNKCJA DAJE ODPOWIEDZ, CZY DANY PROTOTYP JEST KLASA
1514 C   IX - CZESC T ZE SLOWA ZEROWEGO PROTOTYPU
1515 C
1516 C   ****************
1517 C
1518       IFCLASS=IX.EQ.2 .OR. IX.EQ.3 .OR. IX.EQ.5 .OR. IX.EQ.7
1519       RETURN
1520       END
1521       INTEGER FUNCTION INITPR(KIND,NAME)
1522 C
1523 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1524 C   FUNKCJA WYKONUJE WSTEPNE CZYNNOSCI  ( REZERWACJA MIEJSCA,USTAWIENIE
1525 C   LISTY ATRYBUTOW I TABLICY HASHU ) DLA PROTOTYPU.
1526 C      NAME - NAZWA PROTOTYPU
1527 C      KIND - RODZAJ PROTOTYPU
1528 C   WARTOSCIA FUNKCJI JEST IDENTYFIKATOR UTWORZONEGO PROTOTYPU.
1529 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1530 C
1531 C
1532       IMPLICIT INTEGER(A-Z)
1533 C
1534 C
1535       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
1536      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
1537 cdsw  INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
1538 C
1539 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
1540 C    NULLWD(I)  -  WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
1541 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
1542 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
1543 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
1544 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
1545 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
1546 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
1547 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
1548 C    INOUT   -     --   --   --   --           ZMIENNEJ INOUT
1549 C
1550 C
1551 C
1552       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
1553 C
1554 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
1555 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
1556 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
1557 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
1558 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
1559 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
1560 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
1561 C                  PROTOTYPU
1562 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
1563 C
1564 C ..... ZMIENNE GLOBALNE
1565 C
1566 C
1567 C.....
1568       LOGICAL  INSYS,  OWN
1569       COMMON /BLANK/ COM(278),
1570      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1571      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1572      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1573      X        LOCAL , OWN   , OBJECT,
1574      X        IPMEM(5000)
1575 C
1576 cdeb ----------- added ---------------------
1577       common /names/ resnm, mainm, brenam
1578 c   nazwy ze scannera
1579
1580       common /brid/ breaklid
1581 c   numer w displayu (dla interpretera) prototypu breakl
1582 cdeb ---------------------------------------
1583 C
1584 C
1585 C        REZERWACJA MIEJSCA I USTAWIENIE SLOWA ZEROWEGO
1586        IF(KIND.GE.13 .AND.KIND.LE. 16) INSYS=.TRUE.
1587       INITPR = MGETM(SIZEPR(KIND),341)
1588       INSYS=.FALSE.
1589       INITPR=INITPR+NULLPOZ(KIND)
1590       IPMEM(INITPR) = NULLWD(KIND)
1591 C   DOLACZENIE DO LISTY NEXTDECL
1592       IPMEM(LASTPR+2) = INITPR
1593       LASTPR = INITPR
1594 cdeb ----------- added --------------------
1595       if(name.ne.brenam) go to 82
1596 c  przekazanie na zmiennej breaklid numeru prototypu
1597 c procedury breakl
1598 c  obliczenie numeru prototypu
1599       i = nblus
1600       breaklid = 0
1601   80  k = ipmem(i)
1602 c  formaLNE i sygnaly sa pomijane
1603       if(iand(ishft(k,-4),15).ne.0) go to 81
1604       if(i.eq.lastpr) go to 82
1605       breaklid = breaklid+1
1606  81   i = ipmem(i+2)
1607       if(i.ne.0) go to 80
1608  82   continue
1609 cdeb ---------------------------------------
1610       IF ( KIND .GE.17.AND.KIND.LE.20) GO TO 100
1611 C   INICJALIZACJA LISTY ATRYBUTOW
1612       IPMEM(INITPR+7) = INITPR+5
1613       IPMEM(INITPR+5) = NATTR
1614 C   USTAWIENIE SL
1615  100  IPMEM(INITPR-1) = INDPR
1616 C   WSTAWIENIE 1 DO POLA USED - DLA AIL
1617       IPMEM(INITPR+1) = 1
1618 C   DLA BLOKOW I HANDLEROW - KONIEC
1619       IF(KIND.EQ.1.OR. KIND.EQ.8 .OR. KIND.EQ.23) RETURN
1620 C   WSTAWIENIE NAZWY PROTOTYPU DO TABLICY HASH'U
1621 C   JESLI TO JEST PROTOTYP FORMALNY II-GO RZEDU, TO ELEMENTY LISTY HASH'U SA
1622 C   TWORZONE W CZESCI SYSTEMOWEJ
1623       IF( KIND.GE.18 .AND. KIND.LE.20 ) INSYS = .TRUE.
1624       IF( NAME .EQ.NEMPTY) GO TO 200
1625       I = IDPUT(NAME,IPMEM(IHBEG))
1626       IF ( I.EQ.0) GO TO 200
1627       IPMEM(I+2) = INITPR
1628 C    DLA SYGNALOW - KONIEC
1629  200  IF ( KIND.GE.21 ) RETURN
1630 C        WSTAWIENIE DO LISTY ATRYBUTOW ( PROTOTYPU INDPR )
1631 C        JESLI INDPR JEST FORMALNY, TO LISTA ATRYBUTOW JEST TWORZONA
1632 C          W CZESCI SYSTEMOWEJ
1633       CALL MADATR(INITPR,INDPR,41)
1634       INSYS = .FALSE.
1635       RETURN
1636       END
1637       SUBROUTINE MERGEID
1638 C
1639 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1640 C  PODPROGRAM DOKLADA DO ZBIORU IDENTYFIKATOROW PROTOTYPU INDPR
1641 C   IDENTYFIKATORY Z PREFIKSU TAKIE,ZE:
1642 C         -   JESZCZE ICH NIE MA
1643 C          - NIE MA ICH NA LISCIE TAKEN
1644 C  PODPROGRAM JEST WYWOLYWANY O ILE BYL PREFIKS.
1645 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1646 C
1647        IMPLICIT INTEGER (A-Z)
1648 C
1649       LOGICAL ONLY
1650 C
1651 C     INSERTION OF
1652       LOGICAL BTEST
1653 C     BECAUSE OF TYPECONFLICT 03.01.84
1654       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
1655 C
1656 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
1657 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
1658 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
1659 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
1660 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
1661 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
1662 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
1663 C                  PROTOTYPU
1664 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
1665 C
1666 C
1667 C.....
1668       LOGICAL  INSYS,  OWN
1669       COMMON /BLANK/ COM(278),
1670      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1671      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1672      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1673      X        LOCAL , OWN   , OBJECT,
1674      X        IPMEM(5000)
1675 C
1676       LOGICAL ERRFLG
1677       COMMON/STREAM/ERRFLG,LINE,IBUF2(265),IBUF3(7),JUNK(260)
1678       COMMON/MEM/NM,NH
1679       COMMON/DONLY/IONLY,ONIL
1680       LOGICAL ONIL
1681 C
1682 C   **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
1683 C    ROBOCZY BLOK, UZYWANY PRZY TWORZENIU ZBIORU IDENTYFIKATOROW
1684 C    IONLY  -  POCZATEK LISTY TAKEN W ISMEM
1685 C   ONIL=TRUE, GDY JEST TAKEN NIL
1686 C
1687 C
1688 C
1689 C   SPRAWDZAMY, CZY BYLO  TAKEN NIL
1690       ONIL=BTEST(IPMEM(INDSPR+8),14)
1691       IF(ONIL) GO TO 500
1692 C
1693 C   *   *   *   *   *   *
1694 C  SPRAWDZENIE POPRAWNOSCI LISTY TAKEN
1695 C   *   *   *   *   *   *
1696 C
1697 C  IHBEGP  --  POCZATEK LISTY IDENTYFIKATOROW W PREFIKSIE
1698       IHBEGP=INDPREF+10
1699       IONLY=IPMEM(INDSPR+7)
1700       IF(IONLY .EQ.0) GO TO 500
1701 C  J - POPRZEDNI ELEMENT LISTY
1702 C  I - BIEZACY ELEMENT LISTY
1703       J=0
1704       I=IONLY
1705  100  NM=IPMEM(I)
1706       LINE=IPMEM(I+1)
1707       NH=IAND(ISHFT(NM,-1),7)+1
1708       M=MEMPRF(INDPREF)
1709 C  M - ELEMENT LISTY HASHU, JESLI NAZWA NM JEST ZADEKLAROWANA W PREFIKSACH
1710       IF(M .EQ. 0) GO TO 400
1711 C  SPRAWDZAMY, CZY NAZWA JEST HIDDEN
1712       IF(BTEST(IPMEM(M+1),1))  GO TO 300
1713 C   SPRAWDZAMY,CZY NAZWA JEST NOT TAKEN
1714       IF(BTEST(IPMEM(M+1),2)) GO TO 250
1715 C        POPRAWNY ELEMENT LISTY TAKEN
1716       J=I
1717  200  I=IPMEM(I+2)
1718       IF(I.NE.0) GO TO 100
1719       GO TO 500
1720 C   NAZWA JEST NOT TAKEN - USUWAMY Z LISTY TAKEN
1721  250  CALL MERR(321,NM)
1722       GO TO 200
1723 C  NAZWA JEST HIDDEN
1724  300  CALL MERR(304,NM)
1725       GO TO 200
1726 C  NAZWA NIEZADEKLAROWANA
1727  400  CALL MERR(305,NM)
1728 C  DOKLADAMY NAZWE DO ZBIORU IDENTYFIKATOROW
1729       M = MEMBER(NM,IPMEM(IHBEG))
1730       IF(M.NE.0) GO TO 200
1731       M=INSERT(NM,IPMEM(IHBEG),341)
1732       GO TO 200
1733 C
1734 C  *   *   *   *   *   *
1735 C       LACZENIE ZBIOROW IDENTYFIKATOROW
1736 C  *  *   *   *   *  *
1737 C
1738  500  CONTINUE
1739 C   PRZEGLADAMY KOLEJNE PREFIKSY
1740       IDP= INDPREF
1741  800  CONTINUE
1742 C        IE - KONIEC TABLICY IDENTYFIKATOROW W PREFIKSIE
1743       IE= IDP+17
1744 C   IHBEGP - POCZATEK LISTY IDENTYFIKATOROW W PREFIKSIE
1745       IHBEGP=IDP+10
1746       DO 555 I=IHBEGP,IE,1
1747 C        I - INDEKS KOLEJNEGO ELEMENTU TABLICY HASHU
1748 C        J - ELEMENT TABLICY HASHU
1749       J=IPMEM(I)
1750       IF(J.EQ.0) GO TO 555
1751  600   CONTINUE
1752 C   JESLI NAZWA JEST HIDDEN - TO DALEJ
1753       IF(BTEST(IPMEM(J+1),1)) GO TO 700
1754 C JESLI NAZWA JEST NOT TAKEN - TO DALEJ
1755       IF(BTEST(IPMEM(J+1),2)) GO TO 700
1756       NM=IPMEM(J)
1757       IF(ONLY(NM)) GO TO 700
1758 C   NAZWY NIE MA NA LISCIE TAKEN
1759       NH=IAND(ISHFT(NM,-1),7)+1
1760 C   SZUKAMY NAZWY OD INDPR PO PREFIKSACH
1761       IND = INDPR
1762  610  M = IND+9+NH
1763       M = IPMEM(M)
1764  620  IF(M.EQ.0) GO TO 650
1765       IF(IPMEM(M).EQ.NM) GO TO 670
1766       M = IPMEM(M+3)
1767       GO TO 620
1768  650  IND = IPMEM(IND+21)
1769       GO TO 610
1770 C   NAZWA MUSI ZOSTAC ZNALEZIONA
1771 C   JESLI NAZWA BYLA ZNALEZIONA PONIZEJ IDP, TO
1772 C   ALBO BYLA JUZ ROZPATRYWANA, ALBO BYLA JUZ NOT TAKEN,
1773 C   ALBO JEST LOKALNA W INDPR
1774  670  IF(IND.NE.IDP) GO TO 700
1775 C   NAZWE TRZEBA DOSTAWIC
1776        M=INSERT(NM,IPMEM(IHBEG),341)
1777       IPMEM(M+1) = 4
1778       IPMEM(M+2) = IPMEM(J+2)
1779  700  J=IPMEM(J+3)
1780       IF(J.NE.0) GO TO 600
1781  555  CONTINUE
1782 C   PRZECHODZIMY DO NATEPNEGO PREFIKSU
1783       IDP=IPMEM(IDP+21)
1784       IF(IDP.NE.0) GO TO 800
1785       RETURN
1786       END
1787       LOGICAL FUNCTION ONLY(NAME)
1788 C
1789 C   *  *  *  *   *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *
1790 C     FUNKCJA SPRAWDZA, CZY NAZWA NAME JEST NA LISCIE TAKEN
1791 C    POCZATEK LISTY TAKEN - IONLY
1792 C  *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1793 C
1794 C
1795       IMPLICIT INTEGER(A-Z)
1796 C
1797 C.....
1798       LOGICAL  INSYS,  OWN
1799       COMMON /BLANK/ COM(278),
1800      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1801      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1802      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1803      X        LOCAL , OWN   , OBJECT,
1804      X        IPMEM(5000)
1805 C
1806 C
1807       COMMON  / DONLY /  IONLY,ONIL
1808       LOGICAL ONIL
1809 C
1810 C   **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
1811 C    ROBOCZY BLOK, UZYWANY PRZY TWORZENIU ZBIORU IDENTYFIKATOROW
1812 C    IONLY  -  POCZATEK LISTY TAKEN W ISMEM
1813 C   ONIL=TRUE, GDY JEST TAKEN NIL
1814
1815 C
1816 C   JESLI LISTA TAKEN JEST PUSTA, TO ZAKLADAMY, ZE SA W NIEJ WSZYSTKIE
1817 C            NAZWY
1818 C
1819        ONLY=.FALSE.
1820        IF(ONIL) RETURN
1821        IF(IONLY.EQ.0) GO TO 200
1822        I=IONLY
1823  100   IF(IPMEM(I).EQ.NAME) GO TO 200
1824        I=IPMEM(I+2)
1825        IF(I.NE.0) GO TO 100
1826 C   NAZWY NIE MA NA LISCIE TAKEN
1827        RETURN
1828 C  NAZWA JEST NA LISCIE TAKEN
1829  200   ONLY=.TRUE.
1830        RETURN
1831        END
1832       SUBROUTINE CHECK ( IND )
1833 C
1834 C   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
1835 C   POPRAWIA BIT OZNACZAJACY PELNA KLASE POCZAWSZY OD PROTOTYPU  IND
1836 C   KONCZY, JESLI TEN BIT JEST 1
1837 C  * * * * * * * * * * * * * * * * *  *  * * * * * * * * * * * * * * *
1838 C
1839       IMPLICIT INTEGER(A-Z)
1840 C
1841 C     INSERTION OF
1842       LOGICAL BTEST
1843 C     BECAUSE OF TYPECONFLICT 03.01.84
1844 C
1845 C.....
1846       LOGICAL  INSYS,  OWN
1847       COMMON /BLANK/ COM(278),
1848      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1849      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1850      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1851      X        LOCAL , OWN   , OBJECT,
1852      X        IPMEM(5000)
1853 C
1854 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
1855 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
1856 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
1857 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
1858 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
1859 C
1860 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
1861 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
1862 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
1863 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
1864 C
1865 C
1866 C
1867       J=IND
1868  100  I=IPMEM(J)
1869       IF(BTEST(I,0)) RETURN
1870       IPMEM(J) = IOR(I,1)
1871       J=IPMEM(J-1)
1872       GO TO 100
1873        END
1874       INTEGER FUNCTION IDPUT(NAME,THASH)
1875 C
1876 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1877 C  FUNKCJA WSTAWIA NAZWE NAME DO TABLICY THASH UPRZEDNIO SPRWDZAJAC,
1878 C   CZY NAZWA JUZ TAM JEST.
1879 C   JESLI JEST, TO WARTOSCIA FUNKCJI JEST 0 I WYKONYWANE SA REAKCJE NA BLAD
1880 C     ( BLAD NIE JEST SYGNALIZOWANY )
1881 C   JESLI NIE MA , TO WARTOSCIA FUNKCJI JEST WSTAWIANY ELEMENT
1882 C   LISTY HASHU.
1883 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1884 C
1885 C
1886       IMPLICIT INTEGER(A-Z)
1887 C
1888 C.....
1889       LOGICAL  INSYS,  OWN
1890       COMMON /BLANK/ COM(278),
1891      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1892      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1893      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1894      X        LOCAL , OWN   , OBJECT,
1895      X        IPMEM(5000)
1896 C
1897 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
1898 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
1899 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
1900 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
1901 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
1902 C
1903 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
1904 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
1905 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
1906 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
1907 C
1908 C
1909 cdsw  INTEGER THASH(8)
1910       dimension thash(8)
1911 C
1912 C
1913 C        SPRAWDZENIE, CZY NAZWA JEST W TABLICY
1914       I=MEMBER(NAME,THASH)
1915       IF(I.NE.0) GO TO 100
1916 C        NAZWY NIE MA - WSTAWIAMY
1917       IDPUT = INSERT ( NAME,THASH,341)
1918       RETURN
1919 C
1920 C        NAZWA JEST - PODWOJNA DEKLARACJA
1921  100  IDPUT = 0
1922       CALL MERR(309,NAME)
1923 C        SKASOWANIE W ELEMENCIE LISTY HASHU INFORMACJI O HIDDEN I CLOSE
1924       IPMEM(I+1) = 0
1925 C        DOWIAZANIE NAZWY DO OBIEKTU UNIVERSAL
1926       IPMEM(I+2) = NRUNIV
1927       RETURN
1928       END
1929       INTEGER FUNCTION IFTYPE ( NAME)
1930 C
1931 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1932 C   FUNKCJA ZNAJDUJE NAZWE NAME W PROTOTYPIE O IDENTYFIKATORZE  INDPR
1933 C   I DALEJ O SL-ACH.  SPRAWDZA,CZY JEST TO NAZWA TYPU.
1934 C   IFTYPE =   IDENTYFIKATOR TYPU, JESLI TYP JEST POPRAWNY
1935 C      IFTYPE = NRUNIV, GDY TYP JEST NIEZADEKLAROWANY LUB NIEDOSTEPNY
1936 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
1937 C
1938       IMPLICIT INTEGER(A-Z)
1939 C
1940 C     INSERTION OF
1941       LOGICAL BTEST
1942 C     BECAUSE OF TYPECONFLICT 03.01.84
1943 C
1944 C.....
1945       LOGICAL  INSYS,  OWN
1946       COMMON /BLANK/ COM(278),
1947      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
1948      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
1949      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
1950      X        LOCAL , OWN   , OBJECT,
1951      X        IPMEM(5000)
1952 C
1953 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
1954 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
1955 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
1956 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
1957 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
1958 C
1959 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
1960 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
1961 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
1962 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
1963 C
1964 C
1965 C
1966       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
1967 C
1968 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
1969 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
1970 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
1971 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
1972 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
1973 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
1974 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
1975 C                  PROTOTYPU
1976 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
1977 C
1978 C
1979       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
1980      * MPROCES, MCOR, MERPF, MBLOCK, MHAND, MNOTVIRT
1981 C
1982 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
1983 C   MASKI I WZORCE:
1984 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
1985 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
1986 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
1987 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
1988 C    MASKTP - ZAPRZECZENIE MASKI  MTP
1989 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
1990 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
1991 C    MCOR - WZORZEC DLA COROUTINY (7)
1992 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
1993 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
1994 C
1995 C
1996 C
1997 C
1998       IFTYPE=MEMSL(NAME,INDPR)
1999       IF(IFTYPE.EQ.0) GO TO 200
2000       I=IPMEM(IFTYPE+1)
2001       IF(BTEST(I,2)) GO TO  100
2002       IF(.NOT.BTEST(I,1) .OR. OWN) GO TO 400
2003 C   NAZWA JEST HIDDEN
2004       CALL MERR(317,NAME)
2005       GO TO 150
2006 C   NAZWA JEST NOT TAKEN
2007  100  CALL MERR(318,NAME)
2008  150  IFTYPE=NRUNIV
2009       RETURN
2010 C        NAZWA JEST ZADEKLAROWANA
2011  400  IFTYPE = IPMEM(IFTYPE + 2)
2012 C        SPRAWDZENIE, CZY TO JEST NAZWA TYPU
2013       IF(IAND(IPMEM(IFTYPE),MTP).NE.NOTTP) RETURN
2014 C        TO NIE JEST NAZWA TYPU
2015       IFTYPE = NRUNIV
2016       CALL MERR(307,NAME)
2017       RETURN
2018 C        NAZWA JEST NIEZADEKLAROWANA - DKLADAMY JA DO BIEZACEGO PROTOTYPU
2019  200  CALL MERR(306,NAME)
2020       IFTYPE = INSERT(NAME,IPMEM(IHBEG),341)
2021       IFTYPE = NRUNIV
2022       RETURN
2023       END
2024       SUBROUTINE DPUTQ (NSDIC,IDPMEM)
2025 C
2026 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
2027 C   PODPROGRAM WSTAWIA PARE (NSDIC,IDPMEM)  DO KOLEJKI PROTOTYPOW
2028 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
2029 C
2030       IMPLICIT INTEGER(A-Z)
2031 C
2032 C
2033       COMMON  / QUEUE /  BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
2034 cdsw  INTEGER  BQUEUE, EQUEUE
2035       LOGICAL EMPTY
2036 C
2037 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2038 C    ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
2039 C      BQUEUE  -  POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
2040 C      EQUEUE  -  KONIEC      --      --       --      --      --
2041 C      IFIRST  -  PIERWSZY ELEMENT KOLEJKI
2042 C      LAST  -  OSTATNI ELEMENT KOLEJKI
2043 C      EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
2044 C
2045 C
2046 C.....
2047       LOGICAL  INSYS,  OWN
2048       COMMON /BLANK/ COM(278),
2049      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2050      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2051      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2052      X        LOCAL , OWN   , OBJECT,
2053      X        IPMEM(5000)
2054 C
2055 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2056 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2057 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2058 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2059 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2060 C
2061 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2062 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2063 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2064 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2065 C
2066 C
2067 C
2068 C        JESLI DOSZLISMY DO KONCA OBSZARU PRZEZNACZONEGO NA KOLJKE, TO
2069 C        ZACZYNAMY OD POCZATKU
2070       IF ( LAST.EQ.EQUEUE-1) LAST=BQUEUE-2
2071        IF(LAST.EQ.IFIRST-2.AND..NOT.EMPTY) GO TO 100
2072 C        JEST MIEJSCE NA DOSTAWIANIE ELEMENTU DO KOLEJKI
2073       EMPTY=.FALSE.
2074       LAST = LAST+2
2075       IPMEM(LAST) = NSDIC
2076       IPMEM(LAST+1) = IDPMEM
2077       RETURN
2078 C
2079 C        PRZEPELNIENIE OBSZARU PRZEZNACZONEGO NA KOLEJKE
2080 C        PRZERWANIE KOMPILACJI
2081  100  CALL MDROP(343)
2082       RETURN
2083       END
2084       SUBROUTINE DGETQ
2085 C
2086 C
2087 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
2088 C   PODPROGRAM POBIERA PIERWSZY ELEMENT Z KOLEJKI PROTOTYPOW I
2089 C   WSTAWIA NA ZMIENNE INDICT I INDPR Z BLOKU  DGLOB.
2090 C   NIE SPRAWDZA, CZY KOLEJKA JEST PUSTA.
2091 C   JESLI NA SKUTEK WYKONANIA OPERACJI KOLEJKA BEDZIE PUSTA, TO ZMIENNA
2092 C   EMPTY DOSTAJE WARTOSC  TRUE  .
2093 C   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *   *
2094 C
2095 C
2096       IMPLICIT INTEGER(A-Z)
2097 C
2098 C.....
2099       LOGICAL  INSYS,  OWN
2100       COMMON /BLANK/ COM(278),
2101      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2102      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2103      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2104      X        LOCAL , OWN   , OBJECT,
2105      X        IPMEM(5000)
2106 C
2107 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2108 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2109 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2110 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2111 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2112 C
2113 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2114 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2115 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2116 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2117 C
2118 C
2119 C
2120       COMMON  / QUEUE /  BQUEUE, EQUEUE, IFIRST, LAST, EMPTY
2121 cdsw  INTEGER  BQUEUE, EQUEUE
2122       LOGICAL EMPTY
2123 C
2124 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2125 C    ZMIENNE SLUZACE DO ORGANIZACJI KOLEJKI PROTOTYPOW
2126 C      BQUEUE  -  POCZATEK POLA W IPMEM PRZEZNACZONEGO NA KOLEJKE
2127 C      EQUEUE  -  KONIEC      --      --       --      --      --
2128 C      IFIRST  -  PIERWSZY ELEMENT KOLEJKI
2129 C      LAST  -  OSTATNI ELEMENT KOLEJKI
2130 C      EMPTY = TRUE, GDY KOLEJKA JEST PUSTA
2131 C
2132       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
2133 C
2134 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
2135 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
2136 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
2137 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
2138 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
2139 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
2140 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
2141 C                  PROTOTYPU
2142 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
2143 C
2144 C
2145 C
2146       INDICT = IPMEM(IFIRST)
2147       INDPR = IPMEM(IFIRST+1)
2148       IF(LAST.EQ.IFIRST) GO TO 100
2149 C        KOLEJKA MA CO NAJMNIEJ 2 ELEMENTY
2150       IF(IFIRST.EQ.EQUEUE-1) GO TO 50
2151       IFIRST = IFIRST+2
2152       RETURN
2153  50   IFIRST = BQUEUE
2154       RETURN
2155 C
2156 C        KOLEJKA BEDZIE PUSTA
2157  100  EMPTY = .TRUE.
2158       IFIRST=BQUEUE
2159       LAST=BQUEUE-2
2160       RETURN
2161       END
2162       SUBROUTINE HEADER
2163 C
2164 C
2165 C**********************************************C
2166 C   PODPROGRAM PRZETWARZA LISTE PARAMETROW FORMALNYCH
2167 C   PROTOTYPU INDPR
2168 C **********************************************
2169 C
2170       IMPLICIT INTEGER(A-Z)
2171       LOGICAL PQ,ISTPF,FORM2
2172 C     INSERTION OF
2173       LOGICAL BTEST
2174 C     BECAUSE OF TYPECONFLICT 03.01.84
2175 C
2176 C ..... ZMIENNE GLOBALNE
2177 C
2178 C.....
2179       LOGICAL  INSYS,  OWN
2180       COMMON /BLANK/ COM(278),
2181      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2182      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2183      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2184      X        LOCAL , OWN   , OBJECT,
2185      X        IPMEM(5000)
2186 C
2187 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2188 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2189 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2190 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2191 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2192 C
2193 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2194 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2195 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2196 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2197 C
2198 C
2199 C
2200       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
2201 C
2202 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
2203 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
2204 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
2205 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
2206 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
2207 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
2208 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
2209 C                  PROTOTYPU
2210 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
2211 C
2212 C
2213       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
2214       LOGICAL SYGN
2215 C
2216 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
2217 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
2218 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
2219 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
2220 C   SYGN = TRUE, GDY SA TO PARAMETRY SYGNALU
2221 C
2222 C
2223       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
2224      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
2225 C
2226 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2227 C   MASKI I WZORCE:
2228 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
2229 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
2230 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
2231 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
2232 C    MASKTP - ZAPRZECZENIE MASKI  MTP
2233 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
2234 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
2235 C    MCOR - WZORZEC DLA COROUTINY (7)
2236 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW/
2237 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
2238 C    MNOTVIR - WZORZEC DO KASOWANIA BITU "WIRTUAL"
2239 C    MHAND - MASKA DLA HANDLERA
2240 C
2241 C
2242 C
2243       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
2244      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
2245 cdsw  INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
2246 C
2247 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2248 C    NULLWD(I)  -  WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
2249 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
2250 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
2251 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
2252 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
2253 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
2254 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
2255 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
2256 C    INOUT   -     ---  --   --   ---          ZMIENNEJ INOUT
2257 C
2258 C  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -
2259 C
2260 C   SPRAWDZENIE,CZY TYP FORMALNY NIE WYSTEPUJE PO UZYCIU
2261 C   JESLI BLOK - TO IDZIEMY DALEJ
2262       IF(IPMEM(INDSPR).EQ.1) GO TO 1000
2263       SYGN = ISHFT(IAND(IPMEM(INDPR),MPAR),-4).EQ.11
2264       IDPAR = IPMEM(INDSPR+11)
2265       IF(SYGN) IDPAR = IPMEM(INDSPR+4)
2266       FORM2=.FALSE.
2267  100  IF(IDPAR.EQ.0) GO TO 1000
2268       K=IPMEM(IDPAR)
2269  150  IF (FORM2) GO TO 350
2270       IF(K.EQ.7) GO TO 900
2271       IF(K.EQ.3.OR.K.EQ.5) GO TO 200
2272       I1=IDPAR+5
2273       IF(K.GE.8) I1=IDPAR+4
2274       I=IPMEM(I1)
2275 C  I - NAZWA TYPU PARAMETRU
2276 C  SPRAWDZAMY,CZY TEN TYP JEST POZNIEJ W LISCIE PARAMETROW
2277 C   OD IDPAR DO KONCA LISTY
2278       PQ=ISTPF(I,.TRUE.)
2279       IF(PQ) IPMEM(I1)=NEMPTY
2280       IF(K.GE.8) GO TO 900
2281 C  TERAZ SPRAWDZAMY PARAMETRY II-GO RZEDU
2282  200  LFORMB=IDPAR
2283       FORM2=.TRUE.
2284       IDPAR=IPMEM(LFORMB+4)
2285  300  IF(IDPAR.EQ.0) GO TO 800
2286       K=IPMEM(IDPAR)
2287       GO TO 150
2288  350  IF(K.LT.8) GO TO 700
2289       I=IPMEM(IDPAR+4)
2290 C  SZUKAMY TYPU OD IDPAR DO KONCA LISTY II-GO RZEDU
2291       PQ=ISTPF(I,.TRUE.)
2292       IF(.NOT.PQ) GO TO 400
2293       IPMEM(IDPAR+4) = NEMPTY
2294       GO TO 700
2295 C  SZUKAMY TYPU WCZESNIEJ W LISCIE II-GO RZEDU BEZ
2296 C   SYGNALIZACJI BLEDU
2297  400  PQ = ISTPF(I,.FALSE.)
2298       IF( PQ ) GO TO 700
2299 C  SZUKAMY W ZEWNETRZNEJ LISCIE PF OD PRZERABIANEJ
2300 C   PROCEDURY/FUNKCJI DO KONCA
2301       K=IDPAR
2302       IDPAR=LFORMB
2303       PQ = ISTPF(I,.TRUE.)
2304       IF(PQ) IPMEM(K+4) = NEMPTY
2305       IDPAR=K
2306  700  IDPAR = IPMEM(IDPAR+3)
2307       GO TO 300
2308  800  FORM2=.FALSE.
2309       IDPAR=LFORMB
2310  900  IDPAR = IPMEM(IDPAR+3)
2311       GO TO 100
2312 C
2313 C  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -
2314 C
2315 C              PRZETWARZANIE PARAMETROW
2316 C
2317  1000 CONTINUE
2318 C
2319 C   PRZYGOTOWANIA DO PRZETWARZANIA LISTY PF
2320       BEGM=LPML
2321       INSYS=.TRUE.
2322       LFORMB=MGETM(2,341)
2323       LFORME=LFORMB
2324       FORM2=.FALSE.
2325       INSYS=.FALSE.
2326 C  JESLI BLOK TO NIE POSIADA PARAMETROW
2327       IF(IPMEM(INDSPR).EQ.1) GO TO 1500
2328 C
2329 C   PRZETWARZANIE PARAMETROW
2330       IDPAR=IPMEM(INDSPR+11)
2331       IF(SYGN) IDPAR = IPMEM(INDSPR+4)
2332  1100 IF(IDPAR.EQ.0) GO TO 1500
2333       K=IPMEM(IDPAR)
2334       IF(K.EQ.7) GO TO 1200
2335       IF(K.GE.8) GO TO 1300
2336 C  PROCEDURA / FUNKCJA FORMALNA
2337       CALL CHECK(INDPR)
2338       CALL PROCFUN
2339       GO TO 1400
2340 C   TYP FORMALNY
2341  1200 CALL TYPEF
2342       GO TO 1400
2343 C   ZMIENNA
2344  1300 CALL VARIAB
2345  1400 IDPAR=IPMEM(IDPAR+3)
2346       GO TO 1100
2347 C
2348  1500 CONTINUE
2349 C  DOLACZENIE RESULT
2350 C JESLI TO JEST FUNKCJA
2351 C   UWAGA - NAZWA RESULT DOLACZANA W PROTP1
2352       IF(IPMEM(INDSPR).NE.4.AND.IPMEM(INDSPR).NE.6) GO TO 2000
2353       I=MGETM(6,341) + 4
2354       IPMEM(I) = OUTPFW
2355       CALL PUTPF(I)
2356       CALL MADATR(I,INDPR,341)
2357 C   ZAPAMIETANIE 1 W POLU USED - DLA AIL
2358       IPMEM(I+1)=1
2359       IPMEM(INDPR-5) = I
2360 C  DOLACZENIE TYPU
2361       IPMEM(I-4) = IPMEM(INDPR-4)
2362       IPMEM(I-3) = IPMEM(INDPR-3)
2363 C   WYLICZENIE APETYTU RESULT
2364       IPMEM(I) = IAP(I)
2365 C   JESLI TO BYL TYP FORMALNY, TO ZMIANA SLOWA ZEROWEGO
2366       IF(BTEST(IPMEM(INDPR),12))
2367      * IPMEM(I) = IOR(IPMEM(I),ISHFT(1,12 ))
2368 C
2369 C
2370  2000 CONTINUE
2371       FORM2=.FALSE.
2372       IF(INDPREF.EQ.0) GO TO 1700
2373 C   JESLI PREFIKS MIAL BLEDNA LISTE PF, TO NIE DOKLADAMY WLASNEJ
2374       IF (IAND(IPMEM(INDPREF),MERPF).NE.0) GO TO 1850
2375 C   DOPISANIE SWOJEJ LISTY PF
2376  1700  CALL COPY
2377 C   DOLACZENIE LISTY PF Z PREFIKSU
2378       IF(INDPREF.EQ.0) GO TO 3000
2379  1850 I=IPMEM(INDPREF+3)
2380       J=IPMEM(INDPREF+4)
2381       IF(J.EQ.0) GO TO 3000
2382       K=MGETM(J,341)
2383       DO 1666 I1=1,J
2384       I2=K+I1-1
2385       I3=I+I1-1
2386  1666 IPMEM(I2) = IPMEM(I3)
2387       IPMEM(INDPR+3) = K
2388       IPMEM(INDPR+4) = IPMEM(INDPR+4)+J
2389  3000 CONTINUE
2390 C   ZAKONCZENIE
2391       LPML=BEGM
2392       RETURN
2393       END
2394       LOGICAL FUNCTION ISTPF(NM,PQ)
2395 C
2396 C * * * * * * * * * * * * * * * * * * * * * * * *
2397 C   FUNKCJA SPRAWDZA,CZY TYP O NAZWIE NM WYSTEPUJE JAKO
2398 C   FORMALNY W LISCIE PARAMETROW.
2399 C   JESLI PQ=.TRUE., TO SZUKAMY OD IDPAR DO KONCA LISTY
2400 C   I W RAZIE ZNALEZIENIA SYGNALIZUJEMY BLAD.
2401 C   JESLI PQ=.FALSE., TO SZUKAMY OD POCZATKU LOKALNEJ LISTY
2402 C   PARAMETROW(LFORMAB) DO IDPAR I NIE SYBNALIZUJEMY BLEDU.
2403 C   * * * * * * * * * * * * * * * * * * * * * * * * * * * *
2404 C
2405       IMPLICIT INTEGER(A-Z)
2406       LOGICAL PQ
2407 C
2408 C ..... ZMIENNE GLOBALNE
2409 C
2410 C.....
2411       LOGICAL  INSYS,  OWN
2412       COMMON /BLANK/ COM(278),
2413      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2414      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2415      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2416      X        LOCAL , OWN   , OBJECT,
2417      X        IPMEM(5000)
2418 C
2419 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2420 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2421 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2422 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2423 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2424 C
2425 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2426 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2427 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2428 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2429 C
2430       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
2431       LOGICAL FORM2, SYGN
2432 C
2433 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
2434 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W IPMEM
2435 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
2436 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
2437 C   SYNG = TRUE, GDY SA TO PARAMETRY SYGNALU
2438 C
2439 C
2440 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
2441       LOGICAL  ERRFLG
2442       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
2443 C
2444 C
2445 C
2446 C
2447       K=0
2448       IF(.NOT. PQ) K=IDPAR
2449       I=IPMEM(IDPAR+3)
2450       IF(.NOT.PQ) I=IPMEM(LFORMB+4)
2451       ISTPF=.FALSE.
2452  100  IF(I.EQ.K) RETURN
2453       IF(IPMEM(I).NE.7) GO TO 200
2454 C   TYP FORMALNY
2455       IF(IPMEM(I+2) .EQ. NM) GO TO 400
2456  200  I=IPMEM(I+3)
2457       GO TO 100
2458 C  ZNALEZIONY TYP
2459  400  ISTPF=.TRUE.
2460       IF(.NOT.PQ)RETURN
2461       LINE=IPMEM(IDPAR+1)
2462       CALL MERR(316,NM)
2463       RETURN
2464       END
2465       SUBROUTINE PUTPF(ID)
2466 C
2467 C  * * * * * * * * * * * * * * * * * * * * * * * * *
2468 C   WSTAWIA PARAMETR O IDENTYFIKATORZE ID DO LISTY PF
2469 C  * * * * * * * * * * * * * * * * * * * * * * * ***
2470 C
2471       IMPLICIT INTEGER(A-Z)
2472 C
2473 C ..... ZMIENNE GLOBALNE
2474 C
2475 C.....
2476       LOGICAL  INSYS,  OWN
2477       COMMON /BLANK/ COM(278),
2478      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2479      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2480      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2481      X        LOCAL , OWN   , OBJECT,
2482      X        IPMEM(5000)
2483 C
2484 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2485 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2486 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2487 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2488 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2489 C
2490 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2491 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2492 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2493 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2494 C
2495 C
2496 C
2497       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
2498       LOGICAL FORM2, SYGN
2499 C
2500 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
2501 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
2502 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
2503 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
2504 C   SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
2505 C
2506 C
2507 C
2508 C
2509       INSYS=.TRUE.
2510       K=MGETM(2,341)
2511       IPMEM(K) = ID
2512       IPMEM(LFORME+1) = K
2513       LFORME=K
2514       INSYS=.FALSE.
2515       RETURN
2516       END
2517       SUBROUTINE COPY
2518 C
2519 C  * * * * * * * * * * * * * * * * * * * * * * * * *
2520 C   KOPIUJE LISTE PF DO PAMIECI UZYTKOWNIKA
2521 C   I DOWIAZUJE DO PROTOTYPU INDPR
2522 C  * * * * * * * * * * * * * * * * * * * ** * * *  *
2523 C
2524       IMPLICIT INTEGER(A-Z)
2525 C
2526 C ..... ZMIENNE GLOBALNE
2527 C
2528 C.....
2529       LOGICAL  INSYS,  OWN
2530       COMMON /BLANK/ COM(278),
2531      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2532      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2533      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2534      X        LOCAL , OWN   , OBJECT,
2535      X        IPMEM(5000)
2536 C
2537 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2538 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2539 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2540 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2541 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2542 C
2543 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2544 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2545 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2546 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2547 C
2548 C
2549 C
2550       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
2551       LOGICAL FORM2, SYGN
2552 C
2553 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
2554 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
2555 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
2556 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
2557 C   SYN = TRUE, GDY TO SA PARAMETRY SYGNALU
2558 C
2559 C
2560       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
2561 C
2562 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
2563 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
2564 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
2565 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
2566 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
2567 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
2568 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
2569 C                  PROTOTYPU
2570 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
2571 C
2572 C
2573 C
2574 C
2575       I=IPMEM(LFORMB+1)
2576       K=0
2577       L=0
2578       J=0
2579       IF(I.EQ.0) GO TO 400
2580       L=MGETM(1,341)
2581       J=L
2582  100  X=IPMEM(I)
2583       IPMEM(J) = X
2584 C   JESLI TO SA PARAMETRY II-GO RZEDU,TO POPRAWIAMY SL NA INDPR
2585       IF(FORM2) IPMEM(X-1) = INDPR
2586       I=IPMEM(I+1)
2587       K=K+1
2588       IF(I.EQ.0) GO TO 200
2589       J=MGETM(1,341)
2590       GO TO 100
2591  200  CONTINUE
2592 C   L - PIERWSZY PARAMETR
2593 C   J - OSTATNI PARAMETR
2594 C   TRZEBA ZAMIENIC ICH KOLEJNOSC
2595       I1=J
2596       I2=L
2597  300  IF (I1.GE.I2) GO TO 400
2598       X=IPMEM(I1)
2599       IPMEM(I1)=IPMEM(I2)
2600       IPMEM(I2)=X
2601       I1=I1+1
2602       I2=I2-1
2603       GO TO 300
2604  400  IPMEM(INDPR+3) = J
2605       IPMEM(INDPR+4) = K
2606       RETURN
2607       END
2608       SUBROUTINE TYPEF
2609 C
2610 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * *
2611 C   PRZETWARZA TYP FORMALNY.
2612 C   INFORMACJE O PARAMETRZE - W BLOKU DWORK
2613 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * *
2614 C
2615       IMPLICIT INTEGER(A-Z)
2616 C
2617 C ..... ZMIENNE GLOBALNE
2618 C
2619 C.....
2620       LOGICAL  INSYS,  OWN
2621       COMMON /BLANK/ COM(278),
2622      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2623      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2624      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2625      X        LOCAL , OWN   , OBJECT,
2626      X        IPMEM(5000)
2627 C
2628 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2629 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2630 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2631 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2632 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2633 C
2634 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2635 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2636 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2637 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2638 C
2639 C
2640 C
2641       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
2642       LOGICAL FORM2, SYGN
2643 C
2644 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
2645 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
2646 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
2647 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
2648 C   SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
2649 C
2650 C
2651 C
2652 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
2653       LOGICAL  ERRFLG
2654       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
2655 C
2656 C
2657 C   UTWORZENIE OPISU
2658       LINE=IPMEM(IDPAR+1)
2659       KIND=17
2660       IF(FORM2) KIND=20
2661       ID=INITPR(KIND,IPMEM(IDPAR+2))
2662 C   WSTAWIENIE DO LISTY PF
2663       CALL PUTPF(ID)
2664       RETURN
2665       END
2666       SUBROUTINE VARIAB
2667 C
2668 C  * * * * * * * * * * * * * * * * * * * * * * ** * * * *
2669 C   PRZETWARZA PARAMETR BEDACY ZMIENNA
2670 C   INFORMACJE O PARAMETRZE - W BLOKU DWORK
2671 C  * * * * * * * * * * * * * * * * * * * * * * * * * * *
2672 C
2673       IMPLICIT INTEGER(A-Z)
2674 C
2675 C ..... ZMIENNE GLOBALNE
2676 C
2677 C.....
2678       LOGICAL  INSYS,  OWN
2679       COMMON /BLANK/ COM(278),
2680      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2681      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2682      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2683      X        LOCAL , OWN   , OBJECT,
2684      X        IPMEM(5000)
2685 C
2686 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2687 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2688 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2689 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2690 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2691 C
2692 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2693 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2694 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2695 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2696 C
2697 C
2698 C
2699       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
2700       LOGICAL FORM2, SYGN
2701 C
2702 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
2703 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
2704 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
2705 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
2706 C   SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
2707 C
2708 C
2709 C
2710       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
2711 C
2712 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
2713 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
2714 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
2715 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
2716 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
2717 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
2718 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
2719 C                  PROTOTYPU
2720 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
2721 C
2722 C
2723       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
2724      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
2725 C
2726 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2727 C   MASKI I WZORCE:
2728 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
2729 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
2730 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
2731 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
2732 C    MASKTP - ZAPRZECZENIE MASKI  MTP
2733 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
2734 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
2735 C    MCOR - WZORZEC DLA COROUTINY
2736 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
2737 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
2738 C
2739 C
2740 C
2741       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
2742      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
2743 cdsw INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
2744 C
2745 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2746 C    NULLWD(I)  -  WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
2747 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
2748 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
2749 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
2750 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
2751 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
2752 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
2753 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
2754 C    INOUT   -     --    --     ---   --       ZMIENNEJ INOUT
2755 C
2756 C
2757 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
2758       LOGICAL  ERRFLG
2759       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
2760 C
2761 C
2762       LINE = IPMEM(IDPAR+1)
2763       NM=IPMEM(IDPAR+2)
2764 C   .  .  .
2765 C   UTWORZENIE OBIEKTU
2766       ID=MGETM(6,341)+4
2767       IPMEM(ID) = INPFW
2768       IF(IPMEM(IDPAR).EQ.9) IPMEM(ID)=OUTPFW
2769       IF(IPMEM(IDPAR).EQ.10) IPMEM(ID)=INOUT
2770 C   WSTAWIENIE DO ZBIORU IDENTYFIKATOROW
2771       IF(FORM2) INSYS=.TRUE.
2772       K=IDPUT(NM,IPMEM(IHBEG))
2773       IF(K.EQ.0) GO TO 200
2774       IPMEM(K+2) = ID
2775 C   WSTAWIENIE DO LISTY ATRYBUTOW
2776  200  CALL MADATR(ID,INDPR,341)
2777 C   ZAPAMIETANIE 1 W POLU USED - DLA AIL
2778       IPMEM(ID+1)=1
2779 C   WSTAWIENIE DO LISTY PF
2780       CALL PUTPF(ID)
2781 C
2782 C   ROZPOZNANIE TYPU
2783       NM=IPMEM(IDPAR+4)
2784       K=IFTYPE(NM)
2785       IPMEM(ID-3) = K
2786       IPMEM(ID-4) = IPMEM(IDPAR+5)
2787 C   WSTAWIENIE APETYTU
2788       IPMEM(ID) = IAP(ID)
2789 C   JESLI TYP JEST FORMALNY, TO POPRAWIAMY SLOWO ZEROWE
2790       IF(IAND(IPMEM(K),MTP) .NE. 6) RETURN
2791       IPMEM(ID) = IOR(IPMEM(ID),ISHFT(1,12))
2792 C   JESLI TYP FORMALNY JEST NIELOKALNY, TO POPRAWIAMY SPECYFIKACJE
2793 C   PROTOTYPU
2794       IF(LOCAL.EQ.2) RETURN
2795       IF(FORM2) GO TO 300
2796       CALL CHECK(INDPR)
2797 C   JESLI SYGNAL - TO BLAD
2798  250  IF(SYGN) CALL MERR(361,NM)
2799       RETURN
2800 C   JESLI TYP POCHODZI Z TEJ SAMEJ LISTY PARAMETROW CO PROCEDUURA FORMALNA,
2801 C   TO DOBRZE
2802  300  IF(IPMEM(K-1).EQ.IPMEM(INDPR-1)) RETURN
2803       GO TO 250
2804       END
2805       SUBROUTINE PROCFUN
2806 C
2807 C  * * * * * * ** * * * * * * * * * * * * * * * * * * * * *
2808 C   PRZETWARZA PROCEDURE LUB FUNKCJE FORMALNA I-GO RZEDU
2809 C   INFORMACJE O PARAMETRZE W BLOKU DWORK
2810 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * *
2811 C
2812       IMPLICIT INTEGER(A-Z)
2813 C
2814 C ..... ZMIENNE GLOBALNE
2815 C
2816 C.....
2817       LOGICAL  INSYS,  OWN
2818       COMMON /BLANK/ COM(278),
2819      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
2820      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
2821      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
2822      X        LOCAL , OWN   , OBJECT,
2823      X        IPMEM(5000)
2824 C
2825 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
2826 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
2827 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
2828 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
2829 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
2830 C
2831 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
2832 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
2833 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
2834 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
2835 C
2836 C
2837 C
2838       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
2839 C
2840 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
2841 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
2842 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
2843 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
2844 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
2845 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
2846 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
2847 C                  PROTOTYPU
2848 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
2849 C
2850 C
2851 C
2852       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
2853       LOGICAL FORM2, SYGN
2854 C
2855 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
2856 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
2857 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
2858 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
2859 C   SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
2860 C
2861 C
2862       COMMON /DCOPIES/ INDPRC,IHBEGC, IDPARC,LFBC,LFEC
2863 C
2864 C  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *
2865 C   KOPIE ZMIENNYCH Z DGLOB I DWORK
2866 C   INDPRC - KOPIA INDPR
2867 C   IHBEGC - KOPIA IHBEG
2868 C   IDPARC - KOPIA IDPAR
2869 C   LFBC - KOPIA LFORMB
2870 C   LFEC - KOPIA LFORME
2871 C
2872 C
2873       COMMON  / YNIT /  NULLWD(23), SIZEPR(23), NULLPOZ(23), CONSTWD,
2874      *  VARWD,VARPOM,INPFW,OUTPFW, INOUT
2875 cdsw  INTEGER  SIZEPR, CONSTWD, VARWD, VARPOM, OUTPFW
2876 C
2877 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2878 C    NULLWD(I)  -  WZORZEC SLOWA ZEROWEGO DLA PROTOTYPU RODZAJU I
2879 C    SIZEPR(I)  -  ROZMIAR POLA W IPMEM   --   --   --
2880 C    NULLPOZ(I)  -  POZYCJA SLOWA ZEROWEGO  --   --    --
2881 C    CONSTWD  -  WZORZEC SLOWA ZEROWEGO DLA    CONST
2882 C    VARWD  -     --   --   --   --          DLA ZMIENNEJ
2883 C    VARPOM  -     --   --   --   --           ZMIENNEJ POMOCNICZEJ
2884 C    INPFW  -     --   --    --    --          ZMIEMNEJ INPUT
2885 C    OUTPFW  -     --   --    --    --         ZMIENNEJ OUTPUT
2886 C   INOUT    -       --   --   --   ---        ZMIENNEJ INOUT
2887 C
2888 C
2889       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
2890      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
2891 C
2892 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
2893 C   MASKI I WZORCE:
2894 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
2895 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
2896 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
2897 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
2898 C    MASKTP - ZAPRZECZENIE MASKI  MTP
2899 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
2900 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
2901 C    MCOR - WZORZEC DLA COROUTINY (7)
2902 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
2903 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
2904 C
2905 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
2906       LOGICAL  ERRFLG
2907       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
2908 C
2909 C
2910 C
2911 C
2912       NM=IPMEM(IDPAR+2)
2913       LN=IPMEM(IDPAR+1)
2914       LINE=LN
2915 C   .  .  .
2916 C   BEGM - POCZATEK WOLNEGO POLA W PAMIECI SYSTEMOWEJ
2917       BEGM=LPML
2918       LP=LASTPR
2919 C   UTWORZENIE OPISU PARAMETRU
2920       K=IPMEM(IDPAR) + 10
2921       I=INITPR(K,NM)
2922 C   ZAPAMIETANIE KOPII
2923       INDPRC=INDPR
2924       IHBEGC=IHBEG
2925       IDPARC=IDPAR
2926       LFBC=LFORMB
2927       LFEC=LFORME
2928 C   ZAMIANA ZMIENNYCH OKRESLAJACYCH PRZETWARZANY PROTOTYP
2929       INDPR=I
2930       IHBEG=I+10
2931       INSYS=.TRUE.
2932       LFORMB=MGETM(2,341)
2933       LFORME=LFORMB
2934       FORM2=.TRUE.
2935 C
2936 C  -  -  -  -  -  -  -  -  -  -  -   -  -  -  -  -  - -  -
2937 C   PRZETWARZANIE LISTY PF II-GO RZEDU
2938 C
2939 C
2940       INSYS=.FALSE.
2941       IDPAR=IPMEM(IDPAR+4)
2942  100  IF(IDPAR.EQ.0) GO TO 500
2943       KD=IPMEM(IDPAR)
2944       IF(KD.EQ.7) GO TO 200
2945       IF(KD.GE.8) GO TO 300
2946 C  PROCEDURA/FUNKCJA II-GO RZEDU
2947       CALL PROCF2
2948       GO TO 400
2949 C  TYP FORMALNY
2950  200  CALL TYPEF
2951       GO TO 400
2952 C  ZMIENNA
2953  300  CALL VARIAB
2954  400  IDPAR = IPMEM(IDPAR+3)
2955       GO TO 100
2956 C
2957  500  CONTINUE
2958 C
2959 C   -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -  -
2960 C   CZYNNOSCI ORGANIZACYJNE(PAMIEC) I ZAKONCZENIE
2961 C   PRZETWARZANIA  PROCEDURY/FUNKCJI
2962 C
2963       LINE=LN
2964 C   DOLACZENIE RESULT - JESLI TO JEST FUNKCJA
2965       IF(K.EQ.13.OR.K.EQ.15) GO TO 700
2966       I=MGETM(6,341) +4
2967       IPMEM(I) = OUTPFW
2968       CALL MADATR(I,INDPR,341)
2969       CALL PUTPF(I)
2970 C   ZAPAMIETANIE IDENTYFIKATORA RESULT
2971       IPMEM(INDPR-5)=I
2972 C  UWAGA - NAZWY RESULT NIE TRZEBA ZAPAMIETYWAC
2973  700  CONTINUE
2974 C  PRZEPISANIE PROTOTYPU DO CZESCI UZYTKOWNIKA
2975       IF(K.EQ.14 .OR. K.EQ.16) GO TO 750
2976       I=INDPR-2
2977       J=7
2978       KD=MGETM(7,341)
2979       INDPR=KD+2
2980       GO TO 800
2981  750  I=INDPR-5
2982       J=10
2983       KD=MGETM(10,341)
2984       INDPR=KD+5
2985  800  CONTINUE
2986       DO 888 II=1,J
2987       I1=KD+II-1
2988       I2=I+II-1
2989  888  IPMEM(I1) = IPMEM(I2)
2990 C   ZMIANA DOWIAZANIA NEXTDECL W PROTOTYPIE POPRZEDZAJACYM ( LP )
2991       IPMEM(LP+2) = INDPR
2992       IF(IPMEM(INDPR+2).EQ.0) LASTPR = INDPR
2993 C   PRZEPISANIE LISTY PF
2994       CALL COPY
2995 C   POPRAWIENIE ID PROTOTY@PU W TABLICY HASH
2996       I=MEMBER(NM,IPMEM(IHBEGC))
2997       IPMEM(I+2) = INDPR
2998 C   POPRAWIENIE ID PROTOTYPU W LISCIE ATRYBUTOW
2999       I=IPMEM(INDPR-2)
3000 C  I - NUMER ATRYBUTU
3001       KD=IPMEM(INDPRC+6)
3002  920  J=IPMEM(KD)
3003       IF(IPMEM(J-2).EQ.I) GO TO 950
3004        KD=IPMEM(KD+1)
3005       GO TO 920
3006 C  KD - ATRYBUT
3007  950  IPMEM(KD) = INDPR
3008 C   COFNIECIE PAMIECI SYSTEMOWEJ
3009       LPML=BEGM
3010 C   COFNIECIE ZMIENNYCH Z DWORK
3011       LFORMB=LFBC
3012       LFORME=LFEC
3013       IDPAR=IDPARC
3014       FORM2=.FALSE.
3015 C   DOLACZENIE SIEBIE DO LISTY PF
3016       CALL PUTPF(INDPR)
3017 C   COFNIECIE ZMIENNYCH Z DGLOB
3018       I=INDPR
3019       INDPR=INDPRC
3020       IHBEG=IHBEGC
3021 C
3022 C   JESLI FUNKCJA - TO NADANIE TYPU
3023       IF(K.EQ.13 .OR. K.EQ.15) GO TO 1000
3024       NM=IPMEM(IDPAR+5)
3025       J=IFTYPE(NM)
3026       IPMEM(I-3) = J
3027       IPMEM(I-4) = IPMEM(IDPAR+6)
3028       K=IPMEM(I-5)
3029       IPMEM(K-4) = IPMEM(I-4)
3030       IPMEM(K-3) = J
3031 C   JESLI TO JEST TYP FORMALNY, TO POPRAWIAMY SLOWO ZEROWE
3032       IF(IAND(IPMEM(J),MTP).NE.6)  GO TO 1000
3033       IPMEM(I) = IOR(IPMEM(I),ISHFT(1,12))
3034       IPMEM(K) = IOR(IPMEM(K),ISHFT(1,12))
3035 C   JESLI TYP FORMALNY JEST NIELOKALNY, TO ZLE DLA SYGNALU
3036       IF(LOCAL.EQ.2 .OR. .NOT.SYGN) GO TO 1000
3037       CALL MERR(361,NM)
3038  1000 CONTINUE
3039 C   WYPISUJEMY INFORMACJE O PARAMETRACH II-GO RZEDU
3040 C     K=IPMEM(I+3)
3041 C     IF(IPMEM(I+4).EQ.0)RETURN
3042 C     J=IPMEM(I+4)+K-1
3043 C     DO 1111 II=K,J
3044 C     I=IPMEM(II)
3045 C     NM=ISHFT(IAND(IPMEM(I),MPAR),-4)
3046 C     IF(NM.GE.4) GO TO 1112
3047 C     CALL ffwrite(BO(2),"IDENTYFIKATOR =",17)
3048 C     CALL ffwrint(BO(2),I)
3049 C     CALL WRITEPR(I)
3050 C     GO TO 1111
3051 C1112 CALL WATTR(I)
3052 C1111 CONTINUE
3053 C  .  .  .
3054       RETURN
3055       END
3056         SUBROUTINE PROCF2
3057 C
3058 C  **  **  **  ** * * * * * * * * * * * * * * * * *
3059 C   PRZETWARZA PROCEDURE/FUNKCJE FORMALNA II-GO RZEDU
3060 C   PARAMETR DANY PRZEZ ZMIENNE Z BLOKU DWORK
3061 C  * * * * * * * * * * * * * * * * * * * * * * *** *
3062 C
3063         IMPLICIT INTEGER(A-Z)
3064 C
3065 C
3066 C ..... ZMIENNE GLOBALNE
3067 C
3068 C.....
3069       LOGICAL  INSYS,  OWN
3070       COMMON /BLANK/ COM(278),
3071      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3072      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3073      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3074      X        LOCAL , OWN   , OBJECT,
3075      X        IPMEM(5000)
3076 C
3077 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3078 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3079 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3080 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3081 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3082 C
3083 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3084 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3085 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
3086 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
3087 C
3088 C
3089 C
3090 C
3091       COMMON /DWORK/ IDPAR,LFORMB,LFORME,FORM2,SYGN
3092       LOGICAL FORM2, SYGN
3093 C
3094 C  *  *  *  *  *  *   *  *  *  *  *  *  *  *  *  *  *   *  *  *
3095 C   IDPAR - INDEKS SLOWA ZEROWEGO BIEZACEGO PARAMETRU W ISMEM
3096 C   LFORMB,LFORME - PIERWSZY I OSTATNI ELEMENT ROBOCZEJ LISTY PF
3097 C   FORM2=TRUE, GDY PRZETWAEZAMY PARAMETRY II-GO RZEDU
3098 C   SYGN = TRUE, GDY TO SA PARAMETRY SYGNALU
3099 C
3100 C
3101 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
3102       LOGICAL  ERRFLG
3103       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3104 C
3105 C
3106         LINE=IPMEM(IDPAR+1)
3107         NM=IPMEM(IDPAR+2)
3108 C   DOLACZENIE DO LISTY PF ATRYBUTU DODATKOWEGO(BRAK)
3109 C   UTWORZENIE PROTOTYPU
3110         K=IPMEM(IDPAR)+15
3111         I=INITPR(K,NM)
3112 C   DOLACZENIE DO LISTY PF
3113         CALL PUTPF(I)
3114 C   EWENTUALNIE TYP FUNKCJI - BRAK
3115        IF(K.EQ.18) RETURN
3116       IPMEM(I-3)=NRUNIV
3117         RETURN
3118         END
3119       SUBROUTINE VIRTCOM
3120 C
3121 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3122 C   SPRAWDZA KOMPATYBILNOSC WIRTUALI
3123
3124 C   * * * * * * * * * * * * * * * * * ** * * * * * * * * * * *
3125 C
3126       IMPLICIT INTEGER (A-Z)
3127       LOGICAL PARCOM,P
3128 C
3129 C ..... ZMIENNE GLOBALNE
3130 C
3131 C.....
3132       LOGICAL  INSYS,  OWN
3133       COMMON /BLANK/ COM(278),
3134      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3135      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3136      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3137      X        LOCAL , OWN   , OBJECT,
3138      X        IPMEM(5000)
3139 C
3140 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3141 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3142 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3143 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3144 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3145 C
3146 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3147 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3148 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
3149 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
3150 C
3151 C
3152 C
3153       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
3154 C
3155 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
3156 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
3157 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
3158 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
3159 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
3160 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
3161 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
3162 C                  PROTOTYPU
3163 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
3164 C
3165 C
3166 C
3167       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
3168      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
3169 C
3170 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
3171 C   MASKI I WZORCE:
3172 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
3173 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
3174 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
3175 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
3176 C    MASKTP - ZAPRZECZENIE MASKI  MTP
3177 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
3178 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
3179 C    MCOR - WZORZEC DLA COROUTINY (7)
3180 C    MERPF - MASKA DO WYKRYWANIA BLEDNYCH LIST PARAMETROW
3181 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
3182 C
3183 C
3184 C
3185 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
3186       LOGICAL  ERRFLG
3187       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3188 C
3189 C
3190       COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
3191       LOGICAL FORM2,TPVI
3192 C
3193 C   ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
3194 C  ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
3195 C   NM - NAZWA WIRTUALA
3196 C   INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
3197 C   FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
3198 C   TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
3199 C   INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
3200 C     FORMALNYCH
3201 C
3202 C
3203       TPVI=.FALSE.
3204       FORM2=.FALSE.
3205       INDV=IPMEM(INDPR+26)
3206       NM=IPMEM(INDSPR+10)
3207       LINE=IPMEM(INDSPR+9)
3208 C   KONTROLA RODZAJOW WIRTUALI
3209       IRU=ISHFT(IAND(IPMEM(INDV),MOTHERS),-8)
3210       IRL=ISHFT(IAND(IPMEM(INDPR),MOTHERS),-8)
3211       IF (IRU.EQ.IRL) GO TO 50
3212 C   BLAD RODZAJOW
3213       CALL MERR(331,NM)
3214 C   JESLI TO SA FUNKCJE - TO SPRAWDZAMY TYPY
3215  50   IF(IRL.EQ.4 .OR. IRU.EQ.4) GO TO 100
3216       TPVI=.TRUE.
3217       CALL TYPECOM(INDV,INDPR)
3218       TPVI = .FALSE.
3219  100  I=IPMEM(INDPR+3)
3220       IL=IPMEM(INDPR+4)
3221 C   DLA FUNKCJI TRZEBA POMINAC RESULT
3222       IF(IRL.EQ.2) IL=IL-1
3223       J=IPMEM(INDV+3)
3224       JU=IPMEM(INDV+4)
3225       IF(IRU.EQ.2) JU=JU-1
3226 C  I,IL - POCZATEK I DLUGOSC LISTY PF DLA INDPR
3227 C  J,JU - POCZATEK I DLUGOSC LISTY PF DLA INDV
3228       IF(IL+JU.EQ.0) GO TO 1000
3229       IF(IL.NE.JU) GO TO 800
3230 C   ZGODNA LICZBA PARAMETROW
3231  200  IL=IL+I-1
3232       JU=JU+J-1
3233       NM=NEMPTY
3234 C   SPRAWDZENIE ZGODNOSCI PARAMETROW
3235 C   PROCEDURA PARCOM DAJE TRUE, GDY TRZEBA
3236 C   DALEJ SPRAWDZAC ZGODNOSC PF II-GO RZEDU
3237 C  (TZN. SA TO PROCEDURY/FUNKCJE)
3238  300  IF(.NOT.PARCOM(IPMEM(J),IPMEM(I))) GO TO 700
3239 C   SPRAWDZAMY ZGODNOSC PF II-GO RZEDU
3240       FORM2=.TRUE.
3241       INDPR1=IPMEM(I)
3242       INDV1=IPMEM(J)
3243       IRL1=ISHFT(IAND(IPMEM(INDPR1),MOTHERS),-8)
3244       IRU1=ISHFT(IAND(IPMEM(INDV1),MOTHERS),-8)
3245       I1=IPMEM(INDPR1+3)
3246       IL1=IPMEM(INDPR1+4)
3247 C   DLA FUNKCJI - POMIJAMY RESULT
3248       IF(IRL1.EQ.2) IL1 = IL1-1
3249       J1=IPMEM(INDV1+3)
3250       JU1=IPMEM(INDV1+4)
3251       IF(IRU1.EQ.2) JU1 = JU1-1
3252       IF(IL1+JU1.EQ.0) GO TO 600
3253       IF(IL1.NE.JU1) GO TO 500
3254  350  IL1=IL1+I1-1
3255       JU1=JU1+J1-1
3256 C   SPRAWDZANIE ZGODNOSCI PARAMETROW II-GO RZEDU
3257  400  P=PARCOM(IPMEM(J1),IPMEM(I1))
3258       I1=I1+1
3259       J1=J1+1
3260       IF(I1.LE.IL1.AND.J1.LE.JU1) GO TO 400
3261       GO TO 600
3262 C   NIEZGODNA LICZBA PARAMETROW
3263  500  CONTINUE
3264       IF(IL1.LT.JU1) GO TO 530
3265 C   SPRAWDZAMY,CZY LISTA KROTSZA JEST BLEDNA
3266       IF(IAND(IPMEM(INDV1),MERPF).NE.0) GO TO 550
3267       CALL MERR(336,NM)
3268       GO TO 550
3269  530  IF(IAND(IPMEM(INDPR1),MERPF).NE.0) GO TO 550
3270       CALL MERR(336,NM)
3271  550  IF(IL1*JU1.NE.0) GO TO 350
3272  600  CONTINUE
3273 C   KONIEC SPRAWDZANIA PARAMETROW II-GO RZEDU
3274       FORM2=.FALSE.
3275  700  I=I+1
3276       J=J+1
3277       IF(I.LE.IL.AND.J.LE.JU) GO TO 300
3278 C   KONIEC PARAMETROW
3279       GO TO 1000
3280 C  NIEZGODNA LICZBA PARAMETROW
3281  800  IF(IL.LT.JU) GO TO 850
3282       IF(IAND(IPMEM(INDV),MERPF).NE.0) GO TO 900
3283 C   KROTSZA LISTA PF NIE JEST BLEDNA
3284       CALL MERR(333,NM)
3285       GO TO 900
3286  850  IF(IAND(IPMEM(INDPR),MERPF).NE.0) GO TO 900
3287       CALL MERR(333,NM)
3288  900  IF(IL*JU.NE.0) GO TO 200
3289 C
3290  1000 CONTINUE
3291 C   ZAKONCZENIE
3292       RETURN
3293       END
3294       LOGICAL FUNCTION PARCOM(PARU,PARL)
3295 C
3296 C  * * * * * * * * * * * * * * * * * * * * * * ** * * * * * * * * * *
3297 C   SPRAWDZA ZGODNOSCI PARAMETROW O IDENTYFIKATORACH PARU I PARL
3298 C   PARCOM=.TRUE., GDY OBA PARAMETRY SA PROCEDURA LUB FUNKCJA
3299 C   * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3300 C
3301       IMPLICIT INTEGER(A-Z)
3302 C
3303 C ..... ZMIENNE GLOBALNE
3304 C
3305 C.....
3306       LOGICAL  INSYS,  OWN
3307       COMMON /BLANK/ COM(278),
3308      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3309      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3310      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3311      X        LOCAL , OWN   , OBJECT,
3312      X        IPMEM(5000)
3313 C
3314 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3315 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3316 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3317 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3318 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3319 C
3320 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3321 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3322 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
3323 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
3324 C
3325 C
3326 C
3327       COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
3328       LOGICAL FORM2,TPVI
3329 C
3330 C   ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
3331 C  ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
3332 C   NM - NAZWA WIRTUALA
3333 C   INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
3334 C   FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
3335 C   TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
3336 C   INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
3337 C     FORMALNYCH
3338 C
3339 C
3340 C
3341       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
3342      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
3343 C
3344 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
3345 C   MASKI I WZORCE:
3346 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
3347 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
3348 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
3349 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
3350 C    MASKTP - ZAPRZECZENIE MASKI  MTP
3351 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
3352 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
3353 C    MCOR - WZORZEC DLA COROUTINY (7)
3354 C    MERPF - MASKA DO ROZPOZNANIA BLEDNYCH LIST PF
3355 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
3356 C
3357 C
3358 C
3359 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
3360       LOGICAL  ERRFLG
3361       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3362 C
3363 C
3364       IDU=ISHFT(IAND(IPMEM(PARU),MPAR),-4)
3365       IDL=ISHFT(IAND(IPMEM(PARL),MPAR),-4)
3366       PARCOM=.FALSE.
3367 C   .  .  .
3368 C   KONTROLA RODZAJOW
3369       IF(IDU.EQ.IDL) GO TO 100
3370 C   NIEZGODNE RODZAJE
3371       I=334
3372       IF (FORM2) I=337
3373       CALL MERR(I,NM)
3374 C   JESLI OBA PARAMETRY SA ZMIENNYMI, TO KONTROLA TYPOW
3375  100  IF((IDU.EQ.5.OR.IDU.EQ.6.OR.IDU.EQ.9)
3376      * .AND. (IDL.EQ.5.OR.IDL.EQ.6.OR.IDL.EQ.9)) GO TO 300
3377       IF(IDU.NE.2.AND.IDU.NE.3 .OR. IDL.NE.2.AND.IDL.NE.3)
3378      *  RETURN
3379       PARCOM=.TRUE.
3380 C   JESLI OBIE FUNKCJE I-GO RZEDU - TO KONTROLA TYPOW
3381       IF(IDU.NE.2.OR.IDL.NE.2) RETURN
3382       IF(FORM2) RETURN
3383 C   KONTROLA TYPOW
3384  300  CALL TYPECOM(PARU,PARL)
3385       RETURN
3386       END
3387       SUBROUTINE TYPECOM (TPU,TPL)
3388 C
3389 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3390 C   KONTROLA ZGODNOSCI TYPOW
3391 C   TPU,TPL - IDENTYFIKATORY ZMIENNYCH(FUNKCJI)
3392 C   TPVI=.TRUE., GDY TO SA TYPY FUNKCJI VIRTUALNYCH
3393 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3394 C
3395       IMPLICIT INTEGER(A-Z)
3396       LOGICAL POMU,POML,BPREF
3397 C
3398 C ..... ZMIENNE GLOBALNE
3399 C
3400 C.....
3401       LOGICAL  INSYS,  OWN
3402       COMMON /BLANK/ COM(278),
3403      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3404      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3405      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3406      X        LOCAL , OWN   , OBJECT,
3407      X        IPMEM(5000)
3408 C
3409 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3410 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3411 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3412 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3413 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3414 C
3415 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3416 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3417 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
3418 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
3419 C
3420 C
3421 C
3422       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
3423      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
3424 C
3425 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
3426 C   MASKI I WZORCE:
3427 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
3428 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
3429 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
3430 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
3431 C    MASKTP - ZAPRZECZENIE MASKI  MTP
3432 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
3433 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
3434
3435 C    MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
3436 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
3437 C
3438 C
3439 C
3440       COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
3441       LOGICAL FORM2,TPVI
3442 C
3443 C   ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
3444 C  ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
3445 C   NM - NAZWA WIRTUALA
3446 C   INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
3447 C   FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
3448 C   TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
3449 C   INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
3450 C     FORMALNYCH
3451 C
3452 C
3453 C
3454 C  U - TYP WYZSZY
3455 C   IARU,IARL - ILOSC ARRAY OF
3456 C  ITU,ITL - IDENTYFIKATORY TYPOW
3457 C   IDENU,IDNEL - WARTOSCI MTP ZE SLOWA ZEROWEGO TYPOW
3458       ITU=IPMEM(TPU-3)
3459       ITL=IPMEM(TPL-3)
3460       IARU=IPMEM(TPU-4)
3461       IARL=IPMEM(TPL-4)
3462 C   JESLI TYPY SA IDENTYCZNE, TO DOBRZE
3463       IF(IARU.EQ.IARL.AND.ITL.EQ.ITU) RETURN
3464 C   JESLI JEDEN Z TYPOW JEST UNIWERSALNY, TO DOBRZE
3465       IF(ITL.EQ.NRUNIV.OR.ITU.EQ.NRUNIV) RETURN
3466 C   JESLI TYPY ROZNIA SIE TYLKO ARRAY OF , TO ZLE
3467       IF(IARU.NE.IARL.AND.ITL.EQ.ITU) GO TO 999
3468       IDENU=IAND(IPMEM(ITU),MTP)
3469       IDENL=IAND(IPMEM(ITL),MTP)
3470       IF(IDENU.EQ.6) GO TO 500
3471 C   TYP WYZSZY NIE JEST FORMALNY
3472 C   JESLI NIE ZGADZA SIE ARRAY OF , TO BLAD
3473       IF(IARU.NE.IARL) GO TO 999
3474 C   JESLI SA TABLICOWE, TO MUSZA BYC ROWNE
3475       IF(IARU.NE.0.AND.ITU.NE.ITL) GO TO 999
3476 C   JESLI JESZCZE SA TU TYPY PRYMITYWNE, TO BLAD(MUSZA BYC ROWNE)
3477       IF(IDENU.GE.8 .AND. IDENU.LT.13) GO TO 999
3478       IF(IDENL .GE. 8 .AND. IDENL .LT. 13) GO TO 999
3479       IF(ITU.EQ.NRCOR) GO TO 200
3480       IF(ITU.EQ.NRPROC) GO TO 300
3481 C   TYP WYZSZY JEST KLASOWY
3482 C   TYPY MAJA BYC W SEKWENCJI PREFIKSOWEJ
3483       IF(IDENL.EQ.6) GO TO 999
3484       I=IPMEM(ITU-6)
3485       J=IPMEM(ITL-6 )
3486       IF(BPREF(ITL,I)) RETURN
3487       IF(TPVI) GO TO 999
3488       IF(BPREF(ITU,J)) RETURN
3489       GO TO 999
3490 C   WYZSZY - SAMA COROUTINA
3491  200  IF(IDENL.EQ.5 .OR. IDENL.EQ.7) RETURN
3492       IF(BPREF(ITL,IPMEM(NRCOR-6))) RETURN
3493       IF(BPREF(ITL,IPMEM(NRPROC-6))) RETURN
3494       GO TO 999
3495 C   WYZSZY - SAM PROCESS
3496  300  IF(IDENL.EQ.5) RETURN
3497       IF(BPREF(ITL,IPMEM(NRPROC-6))) RETURN
3498       GO TO 999
3499 C
3500 C   WYZSZY - TYP FORMALNY
3501  500  CONTINUE
3502       I=NRPAR(ITU,.TRUE.)
3503       J=NRPAR(ITL,.FALSE.)
3504 C   I,J - NUMERY TYPOW W LISCIE INDV(INDPR)
3505 C   JESLI TO SA PARAMETRY II-GO RZEDU, TO TAKZE
3506 C   W LISCIE PF INDV1(INDPR1)
3507       IF(I+J.EQ.0) GO TO 700
3508       IF(I.NE.J) GO TO 999
3509       IF(IARU.NE.IARL) GO TO 999
3510 C   TRZEBA SPARWDZIC, CZY OBA TYPY SA PARAMETRAMI
3511 C    TEGO SAMEGO RZEDU
3512       I=IPMEM(ITU-1)
3513       J=IPMEM(ITL-1)
3514 C  I,J - SLE
3515       POMU=IAND(IPMEM(I),MPAR).NE.0
3516       POML=IAND(IPMEM(J),MPAR).NE.0
3517       IF(POMU.AND.POML.OR..NOT.(POMU.OR.POML))RETURN
3518       GO TO 999
3519 C
3520 C   TO NIE JEST WLASNY PARAMETR
3521  700  CONTINUE
3522       IF(IARU.NE.0) GO TO 800
3523 C  JESLI WYZSZY NIE JEST TABLICOWY, TO ZLE, GDY
3524 C   NIZSZY JEST PRYMITYWNY NIETABLICOWY
3525       IF(IARL.NE.0) RETURN
3526       IF(IDENL.GE.8.AND.IDENL.LT.13) GO TO 999
3527       RETURN
3528 C   WYZSZY JEST TYPEM TABLICOWYM
3529  800  IF(IDENL.EQ.6) RETURN
3530       IF(IARU.LE.IARL) RETURN
3531 C  SYGNALIZACJA BLEDOW
3532  999  I=335
3533       IF (TPVI) I=332
3534       IF(FORM2) I=338
3535       CALL MERR(I,NM)
3536       RETURN
3537       END
3538       INTEGER FUNCTION NRPAR(IDT,UP)
3539 C
3540 C  * * * * * * *** * * * * * * * * * * * * * * * * * * * * *
3541 C   SPRAWDZA,CZY TYP IDT JEST PARAMETREM INDPR(INDV)
3542 C   UP=.TRUE. - CHODZI O WIRTUAL WYZSZY (INDV)
3543 C   NRPAR - NUMER IDT JAKO PARAMETRU ( LUB 0)
3544 C   JESLI FORM2=.TRUE., TO  BADA TEZ, CZY TYP JEST PARAMETREM/
3545 C   INDV1(ODP. INDPR1)
3546 C   * * * * * * * * * * * * * * * * * * * * * * * * * ** * * *
3547 C
3548       IMPLICIT INTEGER(A-Z)
3549       LOGICAL UP,BPREF
3550 C
3551 C ..... ZMIENNE GLOBALNE
3552 C
3553 C.....
3554       LOGICAL  INSYS,  OWN
3555       COMMON /BLANK/ COM(278),
3556      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3557      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3558      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3559      X        LOCAL , OWN   , OBJECT,
3560      X        IPMEM(5000)
3561 C
3562 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3563 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3564 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3565 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3566 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3567 C
3568 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3569 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3570 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
3571 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
3572 C
3573 C
3574 C
3575       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
3576 C
3577 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
3578 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
3579 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
3580 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
3581 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
3582 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
3583 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
3584 C                  PROTOTYPU
3585 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
3586 C
3587 C
3588 C
3589       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
3590      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
3591 C
3592 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
3593 C   MASKI I WZORCE:
3594 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
3595 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
3596 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
3597 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
3598 C    MASKTP - ZAPRZECZENIE MASKI  MTP
3599 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
3600 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
3601 C    MCOR - WZORZEC DLA COROUTINY (7)
3602 C    MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
3603 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
3604 C
3605 C
3606 C
3607       COMMON /DWV/ NM,INDV,FORM2,TPVI,INDPR1,INDV1
3608       LOGICAL FORM2,TPVI
3609 C
3610 C   ** ** ** ** ** ** ** ** ** ** *** ** ** ** ** ** **
3611 C  ROBOCZY BLOK DO KOMPATYBILNOSCI VIRTUALI
3612 C   NM - NAZWA WIRTUALA
3613 C   INDV - IDENTYFIKATOR WYZSZEGO VIRTUALA
3614 C   FORM2 - TRUE, GDY PRZETWARZAMY PF II-GO RZEDU
3615 C   TPVI - GDY CHODZI O TYP FUNKCJI WIRTUALNEJ
3616 C   INDPR1,INDV1 - IDENTYFIKATORY PRZETWARZANYCH PROCEDUR/FUNKCJI
3617 C     FORMALNYCH
3618 C
3619 C
3620 C
3621 C
3622       NRPAR=0
3623 C   JESLI TYP NIE JEST FORMALNY, TO KONIEC
3624       I=IAND(IPMEM(IDT),MTP)
3625       IF(I.NE.6) RETURN
3626 C  IND - TU SZUKAMY PARAMETRU
3627       IF(FORM2) GO TO 500
3628  300  IND=INDPR
3629       IF(UP) IND=INDV
3630       IS=IPMEM(IDT-1)
3631 C   IS - SL TYPU
3632 C   SPRAWDZAMY, CZY I=IND LUB JEGO PREFIKS
3633       IF(IS.EQ.IND) GO TO 100
3634 C   JESLI IS NIE JEST KLASA, TO KONIEC
3635       IF(IAND(IPMEM(IS),MTP).EQ.1) RETURN
3636       IF(.NOT.BPREF(IND,IPMEM(IS-6))) RETURN
3637 C   TO JEST PARAMETR
3638  100  I=IPMEM(IND+3)
3639  200  NRPAR=NRPAR+1
3640       IF(IPMEM(I).EQ.IDT) RETURN
3641       I=I+1
3642       GO TO 200
3643 C   SZUKAMY W LISCIE II-GO RZEDU
3644  500  IND=INDPR1
3645       IF(UP) IND=INDV1
3646       IF(IS.NE.IND) GO TO 300
3647       GO TO 100
3648       END
3649       SUBROUTINE SIGNAL ( IDSIG )
3650 C
3651       IMPLICIT INTEGER (A-Z)
3652 C
3653 C  * * * * * * ** * * * * * * * * * * ** * * * * * * * * * * * * * * * * *
3654 C   PRZETWARZA SYGNAL O IDENTYFIKATORZE ( SYNTAKTYCZNYM ) IDSIG
3655 C    TWORZY DLA NIEGO KOMPLETNY PROTOTYP
3656 C  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3657 C
3658 C
3659 C.....
3660       LOGICAL  INSYS,  OWN
3661       COMMON /BLANK/ COM(278),
3662      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3663      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3664      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3665      X        LOCAL , OWN   , OBJECT,
3666      X        IPMEM(5000)
3667 C
3668 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3669 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3670 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3671 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3672 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3673 C
3674 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3675 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3676 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
3677 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
3678 C
3679 C
3680       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
3681 C
3682 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
3683 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
3684 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
3685 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
3686 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
3687 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
3688 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
3689 C                  PROTOTYPU
3690 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
3691 C
3692 C
3693 C
3694 cdsw  COMMON /SIGNALS/ NRSIG, HLISTE
3695 cdsw   -----------------------------------------------------
3696       common /signs/ nrsig, hliste
3697 cdsw   -----------------------------------------------------
3698 C
3699 C   NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
3700 C   HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
3701 C
3702 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
3703       LOGICAL  ERRFLG
3704       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3705 C  . . .
3706 C
3707 C   NRPR - NUMER PROTOTYPU SEMANTYCZNEGO
3708       NRPR = IPMEM(IDSIG)
3709       NM = IPMEM(IDSIG+2)
3710       LINE = IPMEM(IDSIG+1)
3711 C   USTAWIENIE BITU CLOSE
3712       I = MEMSL (NM, INDPR )
3713       IPMEM(I+1) = 1
3714 C   PRZYDZIELENIE NUMERU SYGNALU
3715       NRSIG = NRSIG+1
3716       IPMEM(NRPR+1) = NRSIG
3717 C   ZAPAMIETANIE SYNTAKTYCZNEJ LISTY PARAMETROW W PROTOTYIE SYGNALU (KONTROLA)
3718       IPMEM(NRPR+8) = IPMEM(IDSIG+4)
3719 C
3720 C   PRZETWARZANIE NAGLOWKA
3721 C   ZAPAMIETANIE KOPII ZMIENNYZCH OKRESLAJACYCH PRZETWARZANY PROTOTYP
3722       INDC = INDSPR
3723       INDPRC = INDPR
3724       PREFC = INDPREF
3725       IHBEGC = IHBEG
3726 C   NADANIE NOWYCH WARTOSCI
3727       INDPR = NRPR
3728       INDSPR = IDSIG
3729       IHBEG = INDPR+10
3730       INDPREF = 0
3731 C   PRZETWARZANIE NAGLOWKA
3732       CALL HEADER
3733 C   PRZYWROCENIE WARTOSCI ZMIENNYM
3734       INDPR = INDPRC
3735       INDSPR = INDC
3736       IHBEG = IHBEGC
3737       INDPREF = PREFC
3738 C  .  .  .
3739       RETURN
3740       END
3741       SUBROUTINE HANDLER ( IDSMEM )
3742 C
3743       IMPLICIT INTEGER ( A-Z )
3744 C     INSERTION OF
3745       LOGICAL BTEST
3746 C     BECAUSE OF TYPECONFLICT 03.01.84
3747 C
3748 C   ** * * * * ** * * * * * * * * * ** * * * * * ** ** ** * ** * * *** * **
3749 C   PRZETWARZA PROTOTYP HANDLERA
3750 C   IDSMEM - IDENTYFIKATOR PROTOTYPU SYNTAKTYCZNEGO
3751 C   * * * * * * * * * * * * * * * * *** * * * * * * * * * *** * * * * * *
3752 C
3753 C
3754 C.....
3755       LOGICAL  INSYS,  OWN
3756       COMMON /BLANK/ COM(278),
3757      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3758      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3759      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3760      X        LOCAL , OWN   , OBJECT,
3761      X        IPMEM(5000)
3762 C
3763 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3764 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3765 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3766 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3767 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3768 C
3769 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3770 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3771 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
3772 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
3773 C
3774 C
3775 C
3776       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
3777 C
3778 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
3779 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
3780 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
3781 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
3782 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
3783 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
3784 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
3785 C                  PROTOTYPU
3786 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
3787 C
3788 C
3789 C
3790 cdsw  COMMON /SIGNALS/ NRSIG, HLISTE
3791 cdsw  ----------------------------------------------------------
3792       common /signs/ nrsig, hliste
3793 cdsw  ----------------------------------------------------------
3794 C
3795 C   NRSIG - OSTATNIO PRZYDZIELONY NUMER SYGNALU
3796 C   HLISTE - OSTATNI ELEMENT LISTY SYGNALOW (W KAZDYM MODULE )
3797 C
3798 C
3799 C
3800       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
3801      * MPROCES, MCOR, MERPF, MBLOCK, MHAND,MNOTVIR
3802 C
3803 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
3804 C   MASKI I WZORCE:
3805 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
3806 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
3807 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
3808 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
3809 C    MASKTP - ZAPRZECZENIE MASKI  MTP
3810 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
3811 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
3812 C    MCOR - WZORZEC DLA COROUTINY (7)
3813 C    MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
3814 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
3815 C    MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
3816 C
3817 C
3818       COMMON /COPSIG/ BEGADR, IDHAND
3819 C
3820 C   BLOK SLUZACY DO KOMUNIKACJI Z PROCEDURA KOPIUJACA POSZCZEGOLNE PROTOTYPY
3821 C   IDHAND - IDENTYFIKATOR HANDLERA
3822 C   BEGADR - PIERWSZY ELEMENT SLOWNIKA ZAMIANY STARYCH ADRESOW NA NOWE
3823 C    KAZDY ELEMENT SLOWNIKA ZAJMUJE 2 SLOWA: STARY ADRES, NOWY ADRES.
3824 C    OSTATNI ELEMENT SLOWNIKA - LPML-2
3825 C
3826 C
3827 C.....BLOK KOMUNIKACJI ZE STRUMIENIAMI
3828       LOGICAL  ERRFLG
3829       COMMON /STREAM/  ERRFLG, LINE, IBUF2(265), IBUF3(7),JUNK(260)
3830 C
3831 C
3832 C
3833       IDHAND = IPMEM(IDSMEM+1)
3834       LINE = IPMEM(IDSMEM+9)
3835 C
3836 C   PRZEJSCIE PO LISCIE NAZW SYGNALOW
3837 C   ODNALEZIENIE SYGNALOW, SPRAWDZENIE ICH POPRAWNOSCI, UTWORZENIE LISTY
3838 C     HANDLEROW
3839 C   LS - KOLEJNY ELEMENT LISTY
3840 C   POR - ELEMENT LISTY Z KTORYM BEDZIEMY POROWNYWAC
3841 C     NAGLOWKI KOLEJNYCH SYGNALOW
3842       LS = IPMEM(IDSMEM+10)
3843       I = 0
3844       IF(LS.EQ.0) GO TO 810
3845 C   TO NIE JEST HANDLER OTHERS
3846       POR = LS
3847  50   NM = IPMEM(LS)
3848 C   .  .  .
3849       I = MEMSL(NM, INDPR)
3850       IF (I.EQ.0) GO TO 100
3851       IF ( BTEST(IPMEM(I+1),2)) GO TO 150
3852       IF ( .NOT. BTEST(IPMEM(I+1),1) .OR. OWN ) GO TO 300
3853 C   NAZWA JEST HIDDEN
3854       CALL MERR(351,NM)
3855       GO TO 200
3856 C   NAZWA JEST NOT TAKEN
3857  150  CALL MERR (352, NM)
3858       GO TO 200
3859 C   NAZWA NIEZADEKLAROWANA
3860  100  CALL MERR (350, NM)
3861 C   JESLI TO JEST ELEMENT, Z KTORYM MAMY POROWNYWAC, TO GO PRZESUWAMY
3862  200  IF(POR.EQ.LS) POR = IPMEM(LS+1)
3863       GO TO 1000
3864 C
3865 C    NAZWA JEST ZADEKLAROWANA
3866 C    SPRAWDZAMY, CZY TO JEST NAZWA SYGNALU
3867  300  IDSIG = IPMEM(I+2)
3868       J = IPMEM(IDSIG)
3869       J = ISHFT(IAND(J,MPAR),-4)
3870       IF(J.NE.11) GO TO 250
3871 C   TO JEST PROTOTYP SYGNALU
3872 C   JESLI TO JEST PIERWSZY, TO PRZECHODZIMY DO NASTEPNEGO
3873       IF(LS.EQ.IPMEM(IDSMEM+10)) GO TO 800
3874       IF(LS.EQ.POR) GO TO 800
3875 C   SPRAWDZAMY ZGODNOSC PARAMETROW
3876       IF(IAND(IPMEM(IDSIG),MERPF).NE.0) GO TO 400
3877 C   JESLI LS MA DOBRA LISTE PARAMETROW, A POR ZLA - TO ZMIENIAMY POR
3878       J = IPMEM(POR)
3879       IF(IAND(IPMEM(J),MERPF).EQ.0) GO TO 400
3880       POR = LS
3881       GO TO 800
3882 C     TO NIE JEST PROTOTYP SYGNALU
3883  250  CALL MERR ( 353,NM )
3884       GO TO 200
3885 C
3886 C   SPRAWDZAMY ZGODNOSC LISTY PARAMETROW
3887  400  CALL SPRPAR ( IDSIG, IPMEM(POR), NM)
3888 C     DOLACZAMY DO LISTY HANDLEROW
3889  800  I = IPMEM(IDSIG+1)
3890 C   SPRAWDZAMY, CZY HANDLER SI NIE POWTARZA
3891  810   IF(HLISTE.EQ.0) GO TO 830
3892       J=IPMEM(INDPR+20)
3893  820  IF(IPMEM(J).NE.I) GO TO 840
3894       CALL MERR(362,NM)
3895       GO TO 950
3896  840  J=IPMEM(J+2)
3897       IF(J.NE.0) GO TO 820
3898  830  J = MGETM(3,341)
3899       IPMEM(J) = I
3900       IPMEM(J+1) = IDHAND
3901 C   .  .  .
3902       IF(HLISTE.EQ.0) GO TO 850
3903       IPMEM(HLISTE+2)=J
3904       GO TO 900
3905  850  IPMEM(INDPR+20) = J
3906  900  HLISTE = J
3907       IPMEM(INDPR+19) = IPMEM(INDPR+19) + 1
3908 C   JESLI HANDLER OTHERS, TO KONIEC
3909       IF(I.EQ.0) RETURN
3910 C   ZAPAMIETUJEMY IDENTYFIKATOR PROTOTYPU W POLU NAZWY
3911  950  IPMEM(LS) = IDSIG
3912  1000 LS = IPMEM(LS+1)
3913       IF(LS.NE.0) GO TO 50
3914 C
3915 C   KOPIOWANIE ATRYBUTOW
3916 C    POR - Z TEGO SIE KOPIUJE DO HANDLERA
3917 C    POR = 0  -  NIE BYLO ANI JEDNEGO POPRAWNEGO SYGNALU
3918       IF(POR.EQ.0) RETURN
3919       BEGADR = LPML
3920       IDSIG = IPMEM(POR)
3921 C   WSTAWIENIE DO HANDLERA DOWIAZANIA DO SYGNALU
3922       IPMEM(IDHAND+3) = IDSIG
3923 C
3924 C   KOPIOWANIE LISTY ATRYBUTOW RAZEM Z KOPIOWANIEM PROTOTYPOW
3925       I = IPMEM(IDSIG+6)
3926       J = IDHAND+5
3927 C   I - KOLEJNY ELEMENT LISTY ATRYBUTOW PROTOTYPU IDSIG
3928 C   J - OSTATNIO SKOPIOWANY ELEMENT LISTY PROTOTYPU IDHAND
3929       IF(I.EQ.0) RETURN
3930  1100 IPMEM(J+1) = MGETM(2,341)
3931       J = IPMEM(J+1)
3932       IPMEM(J) = ICPROT(IPMEM(I))
3933       I = IPMEM(I+1)
3934       IF(I.NE.0) GO TO 1100
3935 C   USTAWIENIE OSTATNIEGO ATRYBUTU PROTOTYPU IDHAND
3936       IPMEM(IDHAND+7) = J
3937 C
3938 C   KOPIOWANIE TABLICY HASH'U
3939       LPML = LPML-2
3940 C   LPML - OSTATNI ELEMENT SLOWNIKA ZAMIANY ADRESOW
3941       IHSIG = IDSIG+9
3942       IHHAND = IDHAND+9
3943 C
3944       DO 1500 I=1,8
3945 C   I - KOLEJNY ELEMENT TABLICY HASH'U PROTOTYPU IDSIG
3946       J = IHSIG+I
3947       J = IPMEM(J)
3948 C   J - KOLEJNY ELEMENT LISTY HASH'U PROTOTYPU IDSIG
3949       IF(J.EQ.0) GO TO 1500
3950       K = IHHAND+I-3
3951 C   K - OSTATNIO SKOPIOWANY ELEMENT LISTY HASH'U PROTOTYPU IDHAND
3952  1200 IPMEM(K+3) = MGETM(4,341)
3953       K = IPMEM(K+3)
3954       IPMEM(K) = IPMEM(J)
3955       IPMEM(K+1) = IPMEM(J+1)
3956 C   SZUKANIE ODPOWIEDNIEGO ADRESU
3957       II = IPMEM(J+2)
3958       DO 1300 IJ = BEGADR, LPML, 2
3959       IF(IPMEM(IJ).EQ.II) GO TO 1400
3960  1300 CONTINUE
3961  1400 IPMEM(K+2) = IPMEM(IJ+1)
3962       J = IPMEM(J+3)
3963       IF(J.NE.0) GO TO 1200
3964  1500 CONTINUE
3965 C
3966 C   KONIEC KOPIOWANIA - ZWALNIAMY PAMIEC PRZEZNACZONA NA SLOWNIK
3967       LPML = BEGADR
3968       RETURN
3969       END
3970       SUBROUTINE SPRPAR ( EL, ELPOR, NM )
3971 C
3972 C   * * * * * * * * * ** * * * * ** * * * * * * * * * * * * * * * * * * * *
3973 C    POROWNUJE LISTY PARAMETROW SYGNALU O IDENTYFIKATORZE EL I SYGNALU
3974 C    O ODENTYFIKATORZE ELPOR
3975 C     ELPOR - WZORCOWY SYGNAL DO POOWNYWANIA
3976 C    NM - NAZWA SYGNALU EL
3977 C     * * * * * * * * * * * * **** * * * * * ** * * * ** * * * * * * ** ***
3978 C
3979       IMPLICIT INTEGER ( A - Z )
3980 C
3981 C
3982 C.....
3983       LOGICAL  INSYS,  OWN
3984       COMMON /BLANK/ COM(278),
3985      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
3986      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
3987      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
3988      X        LOCAL , OWN   , OBJECT,
3989      X        IPMEM(5000)
3990 C
3991 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
3992 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
3993 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
3994 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
3995 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
3996 C
3997 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
3998 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
3999 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
4000 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
4001 C
4002 C
4003       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
4004      * MPROCES, MCOR, MERPF, MBLOCK, MHAND,MNOTVIR
4005 C
4006 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
4007 C   MASKI I WZORCE:
4008 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
4009 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
4010 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
4011 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
4012 C    MASKTP - ZAPRZECZENIE MASKI  MTP
4013 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
4014 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
4015 C    MCOR - WZORZEC DLA COROUTINY (7)
4016 C    MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
4017 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
4018 C    MNOTVIR - WZORZEC DO KASOWANIA BITU "VIRTUAL"
4019 C
4020 C
4021 C
4022 C    LISTE - LISTA PARAMETROW ( SYNTAKTYCZNA! ) SYGNALU EL
4023 C    LPOR - LISTA PARAMETROW SYGNALU ELPOR
4024 C    LISTY SA PRZECHOWANE W SLOWIE +8 PROTOTYPU SYGNALU
4025 C
4026       LISTE = IPMEM(EL+8)
4027       LPOR = IPMEM(ELPOR+8)
4028  50   IF ( LISTE + LPOR .EQ.0 ) RETURN
4029       IF ( LISTE*LPOR.EQ.0) GO TO 900
4030 C   POROWNYWANIE
4031       KIND = IPMEM(LPOR)
4032       KD = IPMEM(LISTE)
4033       NMP = IPMEM(LISTE+2)
4034 C   NMP - NAZWA PARAMETRU LISTE
4035 C  KONTROLA RODZAJOW
4036       IF(KD.EQ.KIND) GO TO 70
4037 C   MOZE SA NIEZGODNE RODZAJE
4038       IF ( KIND.GE.7 .OR. KD.GE.7 ) GO TO 100
4039 C   SPRAWDZAMY, CZY RODZAJE SA ZGODNE Z DOKLADNOSCIA DO BLEDNYCH LIST PF
4040       IF(IABS(KIND-KD).NE.2) GO TO 100
4041 C    KONTROLA NAZW
4042  70   IF ( NMP.NE.IPMEM(LPOR+2) ) GO TO 200
4043       IF (KIND.LE.6) GO TO 300
4044       IF (KIND.EQ.7) GO TO 400
4045 C   ZMIENNE - POROWNUJEMY TYPY
4046       IF(IPMEM(LISTE+4).NE.IPMEM(LPOR+4)) GO TO 250
4047       IF(IPMEM(LISTE+5).NE.IPMEM(LPOR+5)) GO TO 250
4048 C   NIE MA BLEDU - NASTEPNY ELEMENT LISTY
4049  400  LISTE = IPMEM(LISTE+3)
4050       LPOR = IPMEM(LPOR+3)
4051       GO TO 50
4052 C
4053 C   NIEZGODNE RODZAJE
4054  100  CALL MERR (355,NMP)
4055       GO TO 400
4056 C   ROZNE NAZWY
4057  200  CALL MERR (356,NMP)
4058       GO TO 400
4059 C   ROZNE TYPY
4060  250  CALL MERR(354,NMP)
4061       GO TO 400
4062 C
4063 C   PROCEDURY/FUNKCJE
4064 C   SPRAWDZAMY PARAMETRY II-GO RZEDU
4065  300  I = IPMEM(LISTE+4)
4066       K = IPMEM(LPOR+4)
4067 C   I - ELEMENTY LISTY II-GO RZEDU  PARAMETRU LISTE
4068 C   K - ELEMENTY LISTY II-GO RZEDU PARAMETRU LPOR
4069  350  IF ( I+K.EQ.0) GO TO 800
4070       IF ( I*K.EQ.0 ) GO TO 700
4071 C   KONTROLA
4072       IF ( IPMEM(I).NE.IPMEM(K) ) GO TO 500
4073 C   NIE KONTROLUJE SIE NAZW
4074       IF ( IPMEM(I).LE.7 ) GO TO 600
4075 C   KONTROLA TYPOW
4076       IF ( IPMEM(I+4).NE.IPMEM(K+4) ) GO TO 550
4077       IF ( IPMEM(I+5).NE.IPMEM(K+5) ) GO TO 550
4078 C   NIE MA BLEDOW
4079  600  I = IPMEM(I+3)
4080       K = IPMEM(K+3)
4081       GO TO 350
4082 C   NIEZGODNE RODZAJE
4083  500  CALL MERR ( 357,IPMEM(I+2) )
4084       GO TO 600
4085 C   ROZNE TYPY
4086  550  CALL MERR ( 358, IPMEM(I+2) )
4087       GO TO 600
4088 C   ROZNE DLUGOSCI LIST PARAMETROW II-GO RZEDU
4089 C   JESLI KROTSZA LISTA JEST BLEDNA, TO NIE MA SYGNALIZACJI
4090  700  IF ( I.EQ.0 ) GO TO 750
4091 C  K - KROTSZA
4092       KD = IPMEM(LPOR)
4093  710   IF ( KD.EQ.5.OR.KD.EQ.6) GO TO 800
4094        CALL MERR(359,NMP)
4095       GO TO 800
4096  750  KD = IPMEM(LISTE)
4097       GO TO 710
4098 C
4099 C   KONIE LIST II-GO RZEDU
4100 C   KONTROLA TYPOW - JESLI FUNKCJE
4101  800  IF ( KIND.EQ.3 .OR. KIND.EQ.5 ) GO TO 400
4102       IF(IPMEM(LISTE+5).NE.IPMEM(LPOR+5)) GO TO 250
4103       IF(IPMEM(LISTE+6).NE.IPMEM(LPOR+6)) GO TO 250
4104       GO TO 400
4105 C
4106 C   NIEZGODNE DLUGOSCI LIST PARAMETROW I-GO RZEDU
4107 C   JESLI LISTA KROTSZA JEST BLEDNA, TO NIE MA SYGNALIZACJI
4108  900  IF ( LISTE.EQ.0 ) GO TO 950
4109       IF(IAND(IPMEM(ELPOR),MERPF).EQ.0) CALL MERR(360,NM)
4110       RETURN
4111  950  IF(IAND(IPMEM(EL),MERPF).EQ.0) CALL MERR(360,NM)
4112        RETURN
4113       END
4114        INTEGER FUNCTION ICPROT ( IDPR )
4115 C
4116 C  ** * * * * * * * ** *** ** * * * * * * * * * * ** * * * * * * *
4117 C    KOPIUJE PROTOTYP IDPR ( PROTOTYP PARAMETRU FORMALNEGO).
4118 C    UAKTUALNIA SLOWNIK ZAMIANY ADRESOW PROTOTYPOW.
4119 C    WYNIKIEM FUNKCJI JEST IDENTYFIKATOR UTWORZONEGO PROTOTYPU.
4120 C   * * * * * * * * * ** * * * * * * * * * ** * * * * * * * * * * *
4121 C
4122       IMPLICIT INTEGER ( A - Z )
4123 C
4124 C
4125 C ..... ZMIENNE GLOBALNE
4126 C
4127 C.....
4128       LOGICAL  INSYS,  OWN
4129       COMMON /BLANK/ COM(278),
4130      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
4131      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
4132      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
4133      X        LOCAL , OWN   , OBJECT,
4134      X        IPMEM(5000)
4135 C
4136 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
4137 C             LMEM   - (=5000) ROZMIAR CALEJ PAMIECI GLOWNEJ
4138 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
4139 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
4140 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
4141 C
4142 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
4143 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
4144 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
4145 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
4146 C
4147 C
4148 C
4149       COMMON / DGLOB/ INDICT,INDSPR,INDPR,IHBEG,LASTPR,INDPREF
4150 C
4151 C  **  **  **  **  ***  **  **  **  **  **  **  **  **  **  **  **  **
4152 C    BLOK ZAWIERA DANE O PRZETWARZANYM PROTOTYPIE
4153 C        INDICT  -  INDEKS PRZETWARZANEGO PROTTYPU W ISDICT
4154 C        INDSPR  -  IDENTYFIKATOR PROTOTYPU W ISMEM
4155 C        INDPR  -  IDENTYFIKATOR PROTOTYPU W IPMEM
4156 C        IHBEG  -  ADRES PIERWSZEGO SLOWA TABLICY HASHU
4157 C        IDPREF  -  IDENTYFIKATOR BEZPOSREDNIEGO PREFIKSU PRZETWARZANEGO
4158 C                  PROTOTYPU
4159 C        LASTPR  -  IDENTYFIKATOR POPRZEDNIO PRZETWARZANEGO PROTOTYPU
4160 C
4161 C
4162 C
4163       COMMON  / MASKS /  MTP,MSPR,MOTHERS,MPAR,MASKTP,NOTTP,
4164      * MPROCES, MCOR, MERPF, MBLOCK,MHAND,MNOTVIR
4165 C
4166 C  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **  **
4167 C   MASKI I WZORCE:
4168 C    MTP - MASKA DO WYCINANIA INFORMACJI DOTYCZACYCH TYPOW ZE SLOWA ZEROWEGO
4169 C    MOTHERS -      --     --      --      --     --  INNYCH PROTOTYPOW
4170 C    MPAR -    --    --    --    --    --    --       ZMIENNYCH I PARAMETROW
4171 C    MSPR - MASKA DLA SYSPREF  ( DLA PROTOTYPOW SYNTAKTYCZNYCH )
4172 C    MASKTP - ZAPRZECZENIE MASKI  MTP
4173 C    NOTTP - WZORZEC DLA NIE-TYPU  ( 1 )
4174 C    MPROCES - WZORZEC DLA PROCESU  ( 5 )
4175 C    MCOR - WZORZEC DLA COROUTINY (7)
4176 C    MERPF - MASKA DO ROZPOZNAWANIA BLEDNYCH LIST PARAMETROW
4177 C    MBLOCK - WZORZEC DLA BLOKU  ( 0 PRZY PRZECIECIU Z  MOTHERS )
4178 C
4179 C
4180 C
4181       COMMON /COPSIG/ BEGADR, IDHAND
4182 C
4183 C   BLOK SLUZACY DO KOMUNIKACJI Z PROCEDURA KOPIUJACA POSZCZEGOLNE PROTOTYPY
4184 C   IDHAND - IDENTYFIKATOR HANDLERA
4185 C   BEGADR - PIERWSZY ELEMENT SLOWNIKA ZAMIANY STARYCH ADRESOW NA NOWE
4186 C    KAZDY ELEMENT SLOWNIKA ZAJMUJE 2 SLOWA: STARY ADRES, NOWY ADRES.
4187 C    OSTATNI ELEMENT SLOWNIKA - LPML-2
4188 C
4189 C
4190 C
4191       KIND = ISHFT ( IAND(IPMEM(IDPR),MPAR),-4)
4192       IF(KIND.GT.3) GO TO 400
4193       GO TO (100,200,300), KIND
4194 C
4195 C   TYP FORMALNY
4196  100  ICPROT = MGETM(5,341) + 2
4197 C   DOLACZENIE DO LISTY NEXTDECL
4198       IPMEM(LASTPR+2) = ICPROT
4199       LASTPR = ICPROT
4200       GO TO 1000
4201 C
4202 C   FUNKCJA FORMALNA
4203  200  ICPROT = MGETM(10,341) + 5
4204       GO TO 500
4205 C
4206 C   PROCEDURA FORMALNA
4207  300  ICPROT = MGETM(7,341) + 2
4208 C
4209 C   KOPIOWAIE LISTY PARAMETROW II-GO RZEDU
4210  500  J = IPMEM(IDPR+4)
4211       IPMEM(ICPROT+3) = MGETM(J,341)
4212       IPMEM(ICPROT+4) = J
4213       IF(J.EQ.0) GO TO 1000
4214 C
4215       DO 700 K=1,J
4216       II = IPMEM(IDPR+3) +K-1
4217       II = IPMEM(II)
4218 C   II - IDENTYFIKATOR STAREGO PARAMETRU
4219 C   I - ROZMIAR PROTOTYPU
4220       I = 6
4221       IJ=4
4222       KD=ISHFT(IAND(IPMEM(II),MPAR),-4)
4223       IF(KD.GT.4) GO TO 520
4224       IF(KD.EQ.2) GO TO 510
4225 C   PROCEDURA LUB TYP
4226       I=5
4227       IJ=2
4228       GO TO 520
4229  510  I=7
4230 C   IJ - IDENTYFIKATOR NOWEGO PROTOTYPU
4231  520  IJ = MGETM(I,341) + IJ
4232       IPMEM(IJ) = IPMEM(II)
4233       IPMEM(IJ-1) = ICPROT
4234       IPMEM(IJ-2) = IPMEM(II-2)
4235       IPMEM(IJ+1) = IPMEM(II+1)
4236       IF(KD.LT.5) GO TO  650
4237 C   DLA ZMIENNEJ - WPISANIE TYPU
4238  550  I = IPMEM(II-3)
4239       IPMEM(IJ-4) = IPMEM(II-4)
4240       IPMEM(IJ-3) = I
4241 C  SPRAWDZENIE, CZY JEST TO FORMALNY TYP LOKALNY
4242       I2 = LPML-2
4243       IF(I2.LT.BEGADR) GO TO 690
4244       DO 600 I1 = BEGADR,I2,2
4245       IF(IPMEM(I1).EQ.I) GO TO 610
4246  600  CONTINUE
4247 C   NIE MA TYPU
4248       GO TO 690
4249  610  IPMEM(IJ-3) = IPMEM(I1+1)
4250       GO TO 690
4251 C   DOLOZENIE ADRESU DO SLOWNIKA ( DLA ZMIENNEJ NIE WARTO )
4252  650  INSYS = .TRUE.
4253       I1 = MGETM(2,341)
4254       IPMEM(I1) = II
4255       IPMEM(I1+1) = IJ
4256       INSYS = .FALSE.
4257 C   WSTAWIENIE ADRESU PROTOTYPU DO LISTY PARAMETROW
4258  690  I1 = IPMEM(ICPROT+3) +K-1
4259       IPMEM(I1) = IJ
4260  700  CONTINUE
4261 C
4262       IF(KIND.EQ.3) GO TO 1000
4263 C   FUNKCJA - USTAWIENIE IDENTYFIKATORA RESULT
4264       IPMEM(ICPROT-5) = IJ
4265       GO TO 800
4266 C
4267 C   ZMIENNE
4268  400  ICPROT = MGETM(6,341) + 4
4269 C   KOPIOWANIE TYPU ZMIENNEJ LUB FUNKCJI
4270  800  IPMEM(ICPROT-4) = IPMEM(IDPR-4)
4271       I = IPMEM(IDPR-3)
4272       IPMEM(ICPROT-3) = I
4273 C   SPRAWDZAMY, CZY TO JET TYP FORMALNY LOKALNY
4274       K = LPML-2
4275       IF(K.LT.BEGADR) GO TO 1000
4276 C   JEST NIEPUSTY SLOWNIK ZAMIANY ADRESOW
4277       DO  820 J=BEGADR, K,2
4278       IF(IPMEM(J).EQ.I) GO TO 850
4279  820  CONTINUE
4280 C   NIE MA TAKIEGO TYPU
4281       GO TO 870
4282  850  IPMEM(ICPROT-3) = IPMEM(J+1)
4283 C   JESLI ZMIENNA TO NIE WSTAWIAMY DO NEXTDECL
4284  870  IF(KIND.GE.5) GO TO 1000
4285 C   DLA FUNKCJI - WSTAWIENIE TYPU DO ATRYBUTU RESULT
4286       K = IPMEM(ICPROT-5)
4287       IPMEM(K-4) = IPMEM(ICPROT-4)
4288       IPMEM(K-3) = IPMEM(ICPROT-3)
4289 C
4290 C   UZUPELNIENIE SLOWA ZEROWEGO, ADRESU ATRUBUTU I USED
4291  1000 IPMEM(ICPROT-2) = IPMEM(IDPR-2)
4292       IPMEM(ICPROT-1) = IDHAND
4293       IPMEM(ICPROT)  = IPMEM(IDPR)
4294       IPMEM(ICPROT+1) = IPMEM(IDPR+1)
4295 C
4296 C   UZUPELNIENIE SLOWNIKA ZAMIANY ADRESOW
4297       INSYS = .TRUE.
4298       K = MGETM(2,341)
4299       IPMEM(K) = IDPR
4300       IPMEM(K+1) = ICPROT
4301       INSYS = .FALSE.
4302 C
4303       RETURN
4304       END
4305