sources/pass1/it0.ff

   1 C    Loglan82 Compiler&Interpreter
   2 C     Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3 C     Copyright (C)  1993, 1994 LITA, Pau
   4 C
   5 C     This program is free software; you can redistribute it and/or modify
   6 C     it under the terms of the GNU General Public License as published by
   7 C     the Free Software Foundation; either version 2 of the License, or
   8 C     (at your option) any later version.
   9 C
  10 C     This program is distributed in the hope that it will be useful,
  11 C     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 C     GNU General Public License for more details. File: LICENSE.GNU
  14 C  ===============================================================
  15
  16 c       files used by compiler :
  17 c
  18 c       unit    file description
  19 c
  20 c       13      output sequential (F)     listing (.LST)          (ML2,     )
  21 c       14      temporary direct  (C)     code after parser       (WAN1, ML2)
  22 c       15      output sequential (C)     L-code (.LCD)           (WAN1, ML2)
  23 c       16      temporary sequential (C)  listing                 (WAN1, ML2)
  24 c       17      input sequential (C)      source                  (WAN1, ML2)
  25 c       18      temporary sequential (C)  L-code                  (WAN1, AL11)
  26 c       19      temporary direct (C)      errors                  (WAN2, ML2)
  27 c       21      output sequential (C)     debugger                (WAN1, ML2)
  28 c
  29       subroutine LOGLAN(parlen,parbuf)
  30       integer parlen
  31       character parbuf(1)
  32       IMPLICIT INTEGER (A-Z)
  33 c  parlen - dlugosc linii z parametrami dla kompilatora
  34 c  parbuf - bufor zawierajacy parametry dla kompilatora
  35 C======================================================================C
  36 C                                                                      C
  37 C                        LOGLAN L-COMPILER                             C
  38 C                        =================                             C
  39 C                                                                      C
  40 C     AUTHORS:                                                         C
  41 C                                                                      C
  42 C              DANKA SZCZEPANSKA-WASERSZTRUM                           C
  43 C              MAREK J. LAO                                            C
  44 C              ANDRZEJ I. LITWINIUK                                    C
  45 C              WOJTEK A. NYKOWSKI                                      C
  46 C                                                                      C
  47 C              IIUW, WARSZAWA, 1982                                    C
  48 C                                                                      C
  49 C     PORTED TO SIEMENS 7760 BS2000 BY:                                C
  50 C                                                                      C
  51 C              PAWEL K. GBURZYNSKI                                     C
  52 C              MANFRED KRAUSE                                          C
  53 C              ANDRZEJ I. LITWINIUK                                    C
  54 C                                                                      C
  55 C              IIPMCAU, KIEL, MAY-JUNE 1984                            C
  56 C                                                                      C
  57 C     PORTED TO IBM PC BY                                              C
  58 C              Danuta Szczepanska                                      C
  59 C              Boleslaw Ciesielski                                     C
  60 C              Teresa Przytycka                                        C
  61 C                                                                      C
  62 C     PORTED TO VAX / VMS BY                                           C
  63 C              Danuta Szczepanska                                      C
  64 C              Andrzej Litwiniuk                                       C
  65 C                                                                      C
  66 C     PORTED TO XENIX SCO BY                                           C
  67 C              Pawel Susicki                                           C
  68 C                                                                      C
  69 C     PORTED TO UNIX SCO BY                                            C
  70 C              Pawel Susicki                                           C
  71 C                                                                      C
  72 C     PORTED TO SUN SPARC BY                                           C
  73 C              Pawel Susicki                                           C
  74 C                                                                      C
  75 C======================================================================C
  76       IMPLICIT INTEGER (A-Z)
  77       COMMON /BLANK/ C0M(4) , S, ADRES , K
  78       common /mjlmsg/ierc,msg
  79       integer*4 msg
  80 C======================================================================C
  81 C    THE FOLLOWING FILE UNITS ARE USED:                                C
  82 C                                                                      C
  83 C        1 - INTERACTIVE INPUT FROM THE TERMINAL                       C
  84 C        2 - INTERACTIVE OUTPUT TO THE TERMINAL                        C
  85 C       13 - LISTING OUTPUT                                            C
  86 C       14 - WORKING FILE SCRATCH                                      C
  87 C       15 - L-CODE OUTPUT                                             C
  88 C       16 - PARTIAL LISTING FROM PARSER                               C
  89 C       17 - SOURCE INPUT TO THE COMPILER                              C
  90 C       18 - AUXILIARY SOURCE INPUT                                    C
  91 C       19 - SCRATCH FILE INCLUDING INFO ABOUT COMPILATION ERRORS      C
  92 C======================================================================C
  93 cdsw    byte      jfname
  94         character jfname, param
  95
  96         common /par/ param(256),dl, pozopt
  97 c   param - line of program parameters
  98 c   dl - length of program parameters
  99 c   pozopt -  options position in param
 100
 101       common /jf/jfname(72),jf
 102
 103       call ffputnl(0)
 104       call ffputcs(0,' LOGLAN-82  UNIX Compiler, Version 2.1')
 105       call ffputnl(0)
 106       call ffputcs(0,' January 10, 1993')
 107       call ffputnl(0)
 108       call ffputcs(0,' (C)Copyright  Institute of Informatics,')
 109       call ffputcs(0,' University of Warsaw')
 110       call ffputcs(0,' (C)Copyleft   LITA Universite de Pau')
 111       call ffputnl(0)
 112
 113       ierc = 0
 114       msg = 'it0 '
 115       do 10 jf=1,70
 116 10    jfname(jf) = ' '
 117       do 15 i=1, parlen
 118 15    param(i)=parbuf(i)
 119       dl=parlen
 120       if(dl.ne.0) go to 100
 121       pozopt = 0
 122 200   continue
 123 c  prompt
 124
 125       call ffputcs(0,' File name: ')
 126       call ffgets (0,param,70)
 127
 128       dl = 70
 129 c file name is in  param
 130 100   continue
 131       do 20 pozopt=1,dl
 132       if(param(pozopt).ne.' ') go to 30
 133  20   continue
 134       go to 200
 135  30   jf = 0
 136 50    if(param(pozopt).eq.' '.or.param(pozopt).eq.',' .or.
 137      * param(pozopt).eq.';') go to 300
 138       if (jf.ge.70) go to 40
 139       jf = jf+1
 140       jfname(jf) = param(pozopt)
 141  40   pozopt = pozopt+1
 142       if(pozopt .le. dl) go to 50
 143  300  if (jf.eq.0) go to 200
 144  500  continue
 145       CALL DATA3
 146       CALL DATA
 147       CALL DATA2
 148       CALL MESS
 149       CALL WAN
 150       END
 151
 152
 153       SUBROUTINE DATA3
 154       IMPLICIT INTEGER (A-Z)
 155 C
 156 C  INITIATES THE BLANK COMMON
 157 C  FIXES DIVISION OF IPMEM INTO COMPILER TABLES
 158 C
 159 C
 160       LOGICAL  INSYS,  OWN
 161       COMMON /BLANK/ COM(278),
 162      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 163      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 164      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 165      X        LOCAL , OWN   , OBJECT,
 166      x        IPMEM(5000)
 167 cdsw&bc     X         IPMEM(50000)
 168 C
 169 C             COM    - OBSZAR KOMUNIKACYJNY STRUMIENI
 170 C             LMEM   - (=32000) ROZMIAR CALEJ PAMIECI GLOWNEJ
 171 C             LPMEM  - PODZIAL PAMIECI NA CZESCI  IPMEM  I  ISMEM
 172 C             IRECN  - INDEKS SZCZYTU STOSU STALYCH REAL
 173 C             ISFIN  - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
 174 C
 175 C             LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
 176 C                      NACZONEGO NA PROTOTYPY SYSTEMOWE
 177 C             LPML   - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
 178 C             LPMF   - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
 179 C
 180 C     IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
 181 C             NRINT  - IDENTYFIKATOR PROTOTYPU  INTEGER
 182 C             NRRE   -                          REAL
 183 C             NRBOOL -                          BOOLEAN
 184 C             NRCHR  -                          CHARACTER
 185 C             NRCOR  -                          COROUTINE
 186 C             NRPROC -                          PROCESS
 187 C             NRTEXT -                          STRING (TEXT)
 188 C             NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
 189 C             NATTR  - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
 190 C             NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
 191 C                      REFERENCYJNY)
 192 C             NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
 193 C             NBLUS  -               BLOKU GLOWNEGO UZYTKOWNIKA
 194 C
 195 C             INSYS  - FLAGA SPOSOBU REZERWACJI (PRZEZ  MGETM) PAMIECI
 196 C                      W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
 197 C                      MOWEJ
 198 C             LOCAL  - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
 199 C         BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
 200 C             OWN    - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
 201 C                      POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
 202 C             OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
 203 C                     SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
 204 C
 205 C
 206 C      IN THIS PLACE THE SIZE OF IPMEM MAY BE REDECLARED; THEN THE
 207 C      VARIABLE LMEM (BELOW) SHOULD BE SET TO THE LENGTH OF IPMEM.
 208 C
 209 C
 210 C  IPMEM - MAIN MEMORY AREA OF THE COMPILER
 211 C  LPML  - ADDRESS OF THE FIRST -
 212 C  LPMF  - ADDRESS OF THE LAST FREE WORD IN IPMEM
 213 C  ISFIN - TOP OF THE DICTIONARY OF PROTOTYPES
 214 C  LPMEM - DIVISION POINT OF IPMEM
 215 C  LMEM  - LENGTH OF IPMEM
 216 C
 217       COM(1)=0
 218
 219       lmem = LMEMSIZE
 220       lpmem = LPMEMSIZE+1
 221
 222       IF (LPMEM.GT.4550) GO TO 1
 223 C --- SIZE OF IPMEM TOO SMALL
 224       call ffputcs(0,' Fatal Error:  Memory overflow ')
 225       call ffputnl(0)
 226       call ffexit
 227 c--
 228 1     DO 10 I=3738,LMEM
 229 10    IPMEM(I)=0
 230
 231 C --- 2 BELOW STANDS FOR THE SIZE OF REAL NUMBER EXPRESSED IN THE
 232 C --- NUMBER OF INTEGERS WHICH COVERS THIS SIZE.
 233 cvax  the size of real numbers on vax is 4 bytes ( = the size of integer)
 234 cvax  LPML=LPMEM+2
 235 cdsw  lpml - first free place in real constants
 236 cdsw  in the future -  (lpmem+1) = 0.0, (lpmem+2) = 1.0
 237       lpml = lpmem + WORDS_IN_REAL
 238
 239 C
 240 C  THE FIRST REAL CONSTANT IS 0.0
 241 C
 242       LPMF=LMEM
 243       ISFIN=LPMEM-1
 244       RETURN
 245       END
 246
 247       SUBROUTINE DATA
 248       IMPLICIT INTEGER (A-Z)
 249 cdsw  INTEGER DATAHEX1,DATAHEX2,DATAHEX3
 250 cdsw  DATA    DATAHEX1,DATAHEX2,DATAHEX3 /Z802F,Z0000,ZFFFF/
 251
 252 C
 253 C   INITIATES THE BLANK COMMON
 254 C
 255       DIMENSION X(169),Y(169)
 256       COMMON /BLANK/
 257      $   C0M(4),
 258      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 259      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 260      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 261      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 262      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 263      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 264      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 265      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 266      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 267      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 268      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 269      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 270      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 271      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 272      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 273      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 274      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 275      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 276
 277       common /BLANK/
 278      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 279      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 280      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 281      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 282      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 283      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 284      N   COM(132),
 285      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 286      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 287      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 288      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 289      S   HASH(8000), M,        NAME(10), NLAST,    NL,
 290      T   KEYS(200),
 291      U   TRANS1(13,13),      TRANS2(13,13),      B0,       B(70),
 292      V   SKOK0,    SKOK(70), KK,       MM,       STAN,     STAN1,
 293      W   AUX,      K1,       SY,       SY1,      NU, JK1,  EXP,
 294      X   SIGN,     INTPART,  FRAC,     OKEY,     FRACT,JK2,NB,
 295      Y   TL,       BYTE,     TEXT(20),
 296      Z   TOP,      IN,       NEXT,     STACK(500)
 297
 298       common /BLANK/
 299      *   RESZTA(3652)
 300       REAL   FRACT,NU
 301       EQUIVALENCE (TRANS1(1,1),X(1))
 302       EQUIVALENCE (TRANS2(1,1),Y(1))
 303       LOGICAL OKEY
 304 C     DATA M,HASH,NAME,NLAST,NL /1009,3000*0,10*0,3001,10/
 305 c      #8027 zmienione na #002F - w zapisie uzupelnieniowym
 306       dathx1 = X'002F'
 307       dathx2 = X'0000'
 308 c     #ffff zmienione na -#0001
 309       dathx3 = -X'0001'
 310       M=1009
 311 cdsw  NLAST=3001
 312       nlast =8001
 313       NL=10
 314 cdsw  DO 2 I=1,3000
 315 cdsw2 HASH(I)=0
 316       DO 3 I=1,NL
 317 3     NAME(I)=0
 318 C     DATA TRANS2 /1,3,5,8,3,10,10,16,18,1,10,10,20,2,1,1,8,1,14,14,16,
 319 C    ,18,
 320 C    ,1,14,1,20,1,3,1,9,11,14,14,16,18,1,14,14,20,1,3,6,8,12,14,14,16,
 321 C    ,18,1,14,14,20,1,4,7,8,4,15,15,16,18,1,14,14,20,1,3,1,8,13,14,14,16
 322 C    ,,18,1,14,14,20,1,4,7,8,4,15,15,16,18,1,14,14,20,1,3,7,8,3,14,14,16
 323 C    ,,18,1,14,14,20,1,3,6,10,3,14,14,16,18,1,14,14,20,1,3,1,8,3,14,14,
 324 C    ,16,
 325 C    ,18,1,14,14,20,7*1,17,14*1,19,15*1,21/
 326 C     DATA TRANS1 /1,1,9,5*1,16,17,1,1,1,2,4,4,2,4,2,2,2,16,17,2,4,2,1,5
 327 C    ,,10,1,1,5,5,5,16,17,5,5,5,1,7,11,7,1,7,7,7,16,17,7,7,7,1,5,12,7,5,
 328 C    ,15,1,7,16,17,7,7,7,1,6,13,7,1,6,6,6,16,17,6,6,6,1,6,12,7,6,15,1,7,
 329 C    ,16,17,7,7,7,1,7,12,7,7,7,7,7,16,17,7,7,7,1,8,11,1,8,8,8,8,16,17,8,
 330 C    ,8,8,1,6,14,6,6,6,6,6,16,17,6,6,6,7*3,1,3,3,3,3,3,8*1,17,1,1,1,1,
 331 C    ,13*18/
 332 C     DATA B0,B/10*2,4*1,4,21*1,0,0,3,6,5,10,10,7,12,10,11,8*10,9,3*10,
 333 C    ,8,11*10/
 334 C     DATA SKOK0,SKOK /47*6,1,2,3,4,4,5,18*6/
 335 C ---
 336 cdsw  C0M(2)=DATAHEX1
 337 cdsw  C0M(3)=DATAHEX2
 338 cdsw  C0M(4)=DATAHEX3
 339       c0m(2)=dathx1
 340       c0m(3)=dathx2
 341       c0m(4)=dathx3
 342       CALL OPTDEF
 343 C ---
 344       SKOK0=6
 345       DO 4 I=1,70
 346 4     SKOK(I)=6
 347       SKOK(47)=1
 348       SKOK(48)=2
 349       SKOK(49)=3
 350       SKOK(50)=4
 351       SKOK(51)=4
 352       SKOK(52)=5
 353       SIDENT=1
 354       DO 5 I=1,200
 355 5     KEYS(I)=0
 356 C     DATA S,ADRES,STAN,K,SY,AUX,EXP,SIGN,INTPART,FRAC /10*0/
 357       S=0
 358       ADRES=0
 359       STAN=0
 360       K=0
 361       SY=0
 362       AUX=0
 363       EXP=0
 364       SIGN=0
 365       INTPART=0
 366       FRAC=0
 367 C     DATA OKEY,NU /.FALSE.,0.0/
 368       OKEY=.FALSE.
 369       NU=0.0
 370       SCONST=1000
 371       SEOF=70
 372       SAND=67
 373       SARRAY=18
 374       SARROF=81
 375       SATTACH=11
 376       SBEGIN=83
 377       SBLOCK=22
 378       SBOOL=85
 379       SCALL=9
 380       SCASE=16
 381       SCHAR=71
 382       SCLASS=86
 383       SCLOSE=87
 384       SCONS=88
 385       SCOPY=69
 386       SCOROUT=78
 387       SDETACH=5
 388       SDIM=89
 389       SDO=14
 390       SDOWN=90
 391       SELSE=62
 392       SEND=80
 393       SESAC=91
 394       SEXIT=15
 395       SEXTERN=92
 396       SFI=63
 397       SFOR=17
 398       SFUNCT=93
 399       SIF=2
 400       SINNER=6
 401       SINPUT=95
 402       SINT=64
 403       SKILL=10
 404       SLOCK=7
 405       SNEW=24
 406       SNONE=1002
 407       SNOT=66
 408       SOD=65
 409       SOR=68
 410       SORIF=97
 411       SOTHER=98
 412       SOUTPUT=99
 413       SPREF=23
 414       SPRCD=101
 415       SQUA=76
 416       SREAD=8
 417       SRESUME=12
 418       SRETURN=4
 419       STEP=102
 420       STOP=13
 421       STAKEN=103
 422       STHEN=61
 423       STHIS=74
 424       STO=104
 425       STRUE=1001
 426       STYPE=105
 427       SUNIT=77
 428       SVAR=106
 429       SVIRTUAL=107
 430       SWAIT=21
 431       SWHEN=109
 432       SWHILE=3
 433       SWRIT=19
 434       SWRITLN=20
 435       SCOMA=42
 436       SDOT=38
 437       SEMICOL=45
 438       SCOLON=47
 439       SLEFT=52
 440       SRIGHT=53
 441       SBECOME=54
 442       STAR=50
 443       SRELAT=51
 444 C     DATA BYTE,TL,NB,TEXT /64,20,2,20*0/
 445       BYTE=64
 446       TL=132
 447       NB=2
 448 CBC   TEXT(1)=1
 449       text(1)=2
 450
 451       B0=2
 452       DO 7 I=1,9
 453 7     B(I)=2
 454       DO 8 I=10,35
 455 8     B(I)=1
 456       B(14)=4
 457       B(36)=0
 458       B(37)=0
 459       B(38)=3
 460       B(39)=6
 461       B(40)=5
 462       B(41)=10
 463       B(42)=10
 464       B(43)=7
 465       B(44)=12
 466       B(45)=10
 467       B(46)=11
 468       DO 9 I=47,54
 469 9     B(I)=10
 470       B(55)=9
 471       B(56)=10
 472       B(57)=10
 473       B(58)=10
 474       B(59)=8
 475       DO 10 I=60,70
 476 10    B(I)=10
 477       CALL DAATA
 478       RETURN
 479       END
 480
 481       SUBROUTINE DAATA
 482       IMPLICIT INTEGER (A-Z)
 483       DIMENSION X(169),Y(169)
 484       COMMON /BLANK/
 485      $   C0M(4),
 486      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 487      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 488      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 489      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 490      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 491      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 492      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 493      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 494      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 495      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 496      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 497      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 498      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 499      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 500      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 501      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 502      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 503      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 504
 505       common /BLANK/
 506      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 507      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 508      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 509      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 510      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 511      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 512      N   COM(132),
 513      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 514      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 515      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 516      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 517      S   HASH(8000), M,        NAME(10), NLAST,    NL,
 518      T   KEYS(200),
 519      U   TRANS1(13,13),      TRANS2(13,13),      B0,       B(70),
 520      V   SKOK0,    SKOK(70), KK,       MM,       STAN,     STAN1,
 521      W   AUX,      K1,       SY,       SY1,      NU, JK1,  EXP,
 522      X   SIGN,     INTPART,  FRAC,     OKEY,     FRACT,JK2,NB,
 523      Y   TL,       BYTE,     TEXT(20),
 524      Z   TOP,      IN,       NEXT,     STACK(500)
 525
 526       common /BLANK/
 527      *   RESZTA(3652)
 528       REAL   FRACT,NU
 529       EQUIVALENCE(TRANS1(1,1),X(1))
 530       EQUIVALENCE(TRANS2(1,1),Y(1))
 531       X(  1)=1
 532       X(  2)=1
 533       X(3)=9
 534       X(4)=1
 535       X(5)=1
 536       X(6)=1
 537       X(7)=1
 538       X(8)=1
 539       X(9)=16
 540       X(10)=17
 541       X(11)=1
 542       X(12)=1
 543       X(13)=1
 544       X(14)=2
 545       X(15)=4
 546       X(16)=4
 547       X(17)=2
 548       X(18)=4
 549       X(19)=2
 550       X(20)=2
 551       X(21)=2
 552       X(22)=16
 553       X(23)=17
 554       X(24)=2
 555       X(25)=4
 556       X(26)=2
 557       X(27)=1
 558       X(28)=5
 559       X(29)=10
 560       X(30)=1
 561       X(31)=1
 562       X(32)=5
 563       X(33)=5
 564       X(34)=5
 565       X(35)=16
 566       X(36)=17
 567       X(37)=5
 568       X(38)=5
 569       X(39)=5
 570       X(40)=1
 571       X(41)=7
 572       X(42)=11
 573       X(43)=7
 574       X(44)=1
 575       X(45)=7
 576       X(46)=7
 577       X(47)=7
 578       X(48)=16
 579       X(49)=17
 580       X(50)=7
 581       X(51)=7
 582       X(52)=7
 583       X(53)=1
 584       X(54)=5
 585       X(55)=12
 586       X(56)=7
 587       X(57)=5
 588       X(58)=15
 589       X(59)=1
 590       X(60)=7
 591       X(61)=16
 592       X(62)=17
 593       X(63)=7
 594       X(64)=7
 595       X(65)=7
 596       X(66)=1
 597       X(67)=6
 598       X(68)=13
 599       X(69)=7
 600       X(70)=1
 601       X(71)=6
 602       X(72)=6
 603       X(73)=6
 604       X(74)=16
 605       X(75)=17
 606       X(76)=6
 607       X(77)=6
 608       X(78)=6
 609       X(79)=1
 610       X(80)=6
 611       X(81)=12
 612       X(82)=7
 613       X(83)=6
 614       X(84)=15
 615       X(85)=1
 616       X(86)=7
 617       X(87)=16
 618       X(88)=17
 619       X(89)=7
 620       X(90)=7
 621       X(91)=7
 622       X(92)=1
 623       X(93)=7
 624       X(94)=12
 625       X(95)=7
 626       X(96)=7
 627       X(97)=7
 628       X(98)=7
 629       X(99)=7
 630       X(100)=16
 631       X(101)=17
 632       X(102)=7
 633       X(103)=7
 634       X(104)=7
 635       X(105)=1
 636       X(106)=8
 637       X(107)=11
 638       X(108)=1
 639       X(109)=8
 640       X(110)=8
 641       X(111)=8
 642       X(112)=8
 643       X(113)=16
 644       X(114)=17
 645       X(115)=8
 646       X(116)=8
 647       X(117)=8
 648       X(118)=1
 649       X(119)=6
 650       X(120)=14
 651       X(121)=6
 652       X(122)=6
 653       X(123)=6
 654       X(124)=6
 655       X(125)=6
 656       X(126)=16
 657       X(127)=17
 658       X(128)=6
 659       X(129)=6
 660       X(130)=6
 661       DO 13 I=131,143
 662 13    X(I)=3
 663       X(138)=1
 664       DO 14 I=144,156
 665 14    X(I)=1
 666       X(152)=17
 667       DO 15 I=157,169
 668 15    X(I)=18
 669       Y(1)=1
 670       Y(2)=3
 671       Y(3)=5
 672       Y(4)=8
 673       Y(5)=3
 674       Y(6)=10
 675       Y(7)=10
 676       Y(8)=16
 677       Y(9)=18
 678       Y(10)=1
 679       Y(11)=10
 680       Y(12)=10
 681       Y(13)=20
 682       Y(14)=2
 683       Y(15)=1
 684       Y(16)=1
 685       Y(17)=8
 686       Y(18)=1
 687       Y(19)=14
 688       Y(20)=14
 689       Y(21)=16
 690       Y(22)=18
 691       Y(23)=1
 692       Y(24)=14
 693       Y(25)=1
 694       Y(26)=20
 695       Y(27)=1
 696       Y(28)=3
 697       Y(29)=1
 698       Y(30)=9
 699       Y(31)=11
 700       Y(32)=14
 701       Y(33)=14
 702       Y(34)=16
 703       Y(35)=18
 704       Y(36)=1
 705       Y(37)=14
 706       Y(38)=14
 707       Y(39)=20
 708       Y(40)=1
 709       Y(41)=3
 710       Y(42)=6
 711       Y(43)=8
 712       Y(44)=12
 713       Y(45)=14
 714       Y(46)=14
 715       Y(47)=16
 716       Y(48)=18
 717       Y(49)=1
 718       Y(50)=14
 719       Y(51)=14
 720       Y(52)=20
 721       Y(53)=1
 722       Y(54)=4
 723       Y(55)=7
 724       Y(56)=8
 725       Y(57)=4
 726       Y(58)=15
 727       Y(59)=15
 728       Y(60)=16
 729       Y(61)=18
 730       Y(62)=1
 731       Y(63)=14
 732       Y(64)=14
 733       Y(65)=20
 734       Y(66)=1
 735       Y(67)=3
 736       Y(68)=1
 737       Y(69)=8
 738       Y(70)=13
 739       Y(71)=14
 740       Y(72)=14
 741       Y(73)=16
 742       Y(74)=18
 743       Y(75)=1
 744       Y(76)=14
 745       Y(77)=14
 746       Y(78)=20
 747       Y(79)=1
 748       Y(80)=4
 749       Y(81)=7
 750       Y(82)=8
 751       Y(83)=4
 752       Y(84)=15
 753       Y(85)=15
 754       Y(86)=16
 755       Y(87)=18
 756       Y(88)=1
 757       Y(89)=14
 758       Y(90)=14
 759       Y(91)=20
 760       Y(92)=1
 761       Y(93)=3
 762       Y(94)=7
 763       Y(95)=8
 764       Y(96)=3
 765       Y(97)=14
 766       Y(98)=14
 767       Y(99)=16
 768       Y(100)=18
 769       Y(101)=1
 770       Y(102)=14
 771       Y(103)=14
 772       Y(104)=20
 773       Y(105)=1
 774       Y(106)=3
 775       Y(107)=6
 776       Y(108)=10
 777       Y(109)=3
 778       Y(110)=14
 779       Y(111)=14
 780       Y(112)=16
 781       Y(113)=18
 782       Y(114)=1
 783       Y(115)=14
 784       Y(116)=14
 785       Y(117)=20
 786       Y(118)=1
 787       Y(119)=3
 788       Y(120)=1
 789       Y(121)=8
 790       Y(122)=3
 791       Y(123)=14
 792       Y(124)=14
 793       Y(125)=16
 794       Y(126)=18
 795       Y(127)=1
 796       Y(128)=14
 797       Y(129)=14
 798       Y(130)=20
 799       DO 50 I=131,168
 800 50    Y(I)=1
 801       Y(138)=17
 802       Y(153)=19
 803       Y(169)=21
 804       RETURN
 805       END
 806
 807       SUBROUTINE OPTDEF
 808       IMPLICIT INTEGER (A-Z)
 809 C --- READS INPUT PARAMETERS; APPROPRIATELY MODIFIES OPTION WORD
 810       COMMON /BLANK/
 811      $   C0M(4),
 812      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 813      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 814      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 815      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 816      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 817      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 818      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 819      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 820      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 821      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 822      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 823      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 824      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 825      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 826      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 827      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 828      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 829      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 830
 831        common /BLANK/
 832      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 833      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 834      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 835      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 836      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 837      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 838      N   COM(132),
 839      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 840      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 841      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 842      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 843      S   HASH(8000),  M,    NAME(10), NLAST,    NL,
 844      T   KEYS(200),
 845      U   TRANS1(13,13),      TRANS2(13,13),      B0,       B(70),
 846      V   SKOK0,    SKOK(70), KK,       MM,       STAN,     STAN1,
 847      W   AUX,      K1,       SY,       SY1,      NU,       EXP,
 848      X   SIGN,     INTPART,  FRAC,     OKEY,     FRACT,    NB,
 849      Y   TL,       BYTE,     TEXT(20),
 850      Z   TOP,      IN,       NEXT,     STACK(500)
 851
 852       common /BLANK/
 853      *   RESZTA(3652)
 854
 855        character param
 856         common /par/ param(256),dl, pozopt
 857 c   param - line of program parameters
 858 c   dl - length of program parameters
 859 c   pozopt -  options position in param
 860 C
 861 C
 862       ext = 0
 863       if(pozopt .gt.dl .or. dl .eq. 0) go to 1000
 864   80  k = pozopt
 865       do 101 pozopt = k,dl
 866       if(param(pozopt).ne.' ') go to 102
 867 101   continue
 868       go to 1000
 869 102   if ( ext .eq. 1) go to 105
 870       ext = 1
 871       if(param(pozopt).eq.';') go to 9999
 872       if(param(pozopt) .ne.',') go to 105
 873       pozopt = pozopt+1
 874       go to 80
 875 105   i = 0
 876       do 103 k = pozopt, dl
 877       if(i.ge.70) go to 107
 878       i = i+1
 879  103  skok(i) = ichar(param(k))
 880  107  i = i+1
 881       do 112 k = i,70
 882  112  skok(k) = 0
 883       go to 2000
 884 1000  continue
 885
 886 cvax ------added
 887 cps      write(*,1)
 888 cps1     format (
 889 cps     * ' Specify compilation options : (default = D-S-L-O+T+M+I+)'$)
 890
 891 cps 3    do 111 k=1,70
 892 cps111   skok(k) = 0
 893 cps      read (*,2) skok
 894 cps2     format(70a1)
 895  2000 continue
 896       K=1
 897 C
 898 10     znak = iand(X'ff', skok(k))
 899       K=K+1
 900       IF (ZNAK.EQ.ICHAR(' ')) GO TO 10
 901       IF (ZNAK.EQ.ICHAR(',')) GO TO 10
 902       IF (ZNAK.EQ.0) GOTO 9999
 903 C
 904 20    sign = iand(X'ff', skok(k))
 905       K=K+1
 906       IF (SIGN.EQ.ICHAR(' ')) GOTO 20
 907       IF (SIGN.EQ.ICHAR('+')) GOTO 30
 908       IF (SIGN.EQ.ICHAR('-')) GOTO 30
 909 C --- BAD OPTION
 910 29    call ffputcs(0,' Bad option - ignored')
 911       call ffputnl(0)
 912       go to 9999
 913 30    IF (ZNAK.GT.ICHAR('Z')) ZNAK = ZNAK-32
 914 C     IF (ZNAK.EQ.ICHAR('C')) GOTO 670
 915       IF (ZNAK.EQ.ICHAR('D')) GOTO 680
 916 C     IF (ZNAK.EQ.ICHAR('F')) GOTO 700
 917 cdsw  IF (ZNAK.EQ.ICHAR('I')) GOTO 730
 918       IF (ZNAK.EQ.ICHAR('L')) GOTO 760
 919 cdsw  IF (ZNAK.EQ.ICHAR('M')) GOTO 770
 920       IF (ZNAK.EQ.ICHAR('O')) GOTO 790
 921 C --- IF (ZNAK.EQ.ICHAR('P')) GOTO 800
 922 cdeb
 923       IF (ZNAK.EQ.ICHAR('S')) GOTO 830
 924 cdeb
 925       IF (ZNAK.EQ.ICHAR('T')) GOTO 840
 926       if (znak.eq.ichar('H')) go to 620
 927       GOTO 29
 928 c  opcja 'H' - duza pamiec
 929 c  rozpoznano 'H'
 930 620   continue
 931 #if ! ( DISABLE_H == 1 )
 932       if(sign.eq.ichar('+')) go to 625
 933       c0m(4) = ibclr(c0m(4),12)
 934       go to 10
 935 625   c0m(3) = ibset(c0m(3),12)
 936 #endif
 937       go to 10
 938 C  ROZPOZNANO 'C'
 939 C  ****** "ROZPOZNANO" MEANS "RECOGNIZED"
 940 C 670 IF (SIGN.EQ.ICHAR('+')) GO TO 675
 941 C     C0M(4)=IBCLR(C0M(4),5)
 942 C     GOTO 10
 943 C 675 C0M(3)=IBSET(C0M(3),5)
 944 C     GOTO 10
 945 C  ROZPOZNANO 'D'
 946 680   IF (SIGN.EQ.ICHAR('+')) GO TO 685
 947       C0M(4)=IBCLR(C0M(4),4)
 948       GOTO 10
 949 685   C0M(3)=IBSET(C0M(3),4)
 950       GOTO 10
 951 C  ROZPOZNANO 'F'
 952 C 700 IF (SIGN.EQ.ICHAR('+')) GOTO 705
 953 C     C0M(4)=IBCLR(C0M(4),6)
 954 C     GOTO 10
 955 C 705 C0M(3)=IBSET(C0M(3),6)
 956 C     GOTO 10
 957 C  ROZPOZNANO 'I'
 958 C 730   IF (SIGN.EQ.ICHAR('+')) GOTO 735
 959 C       C0M(4)=IBCLR(C0M(4),2)
 960 C       GOTO 10
 961 C 735   C0M(3)=IBSET(C0M(3),2)
 962 C       GOTO 10
 963 C  ROZPOZNANO 'L'
 964 760   IF (SIGN.EQ.ICHAR('+')) GOTO 765
 965       C0M(4)=IBCLR(C0M(4),15)
 966       GOTO 10
 967 765   C0M(3)=IBSET(C0M(3),15)
 968       GOTO 10
 969 C  ROZPOZNANO 'M'
 970 C 770   IF (SIGN.EQ.ICHAR('+')) GOTO 775
 971 C       C0M(4)=IBCLR(C0M(4),0)
 972 C       GOTO 10
 973 C 775   C0M(3)=IBSET(C0M(3),0)
 974 C       GOTO 10
 975 C  ROZPOZNANO 'O'
 976 790   IF (SIGN.EQ.ICHAR('+')) GOTO 795
 977       C0M(4)=IBCLR(C0M(4),1)
 978       GOTO 10
 979 795   C0M(3)=IBSET(C0M(3),1)
 980       GOTO 10
 981 C  ROZPOZNANO 'P'
 982 C 800 IF (SIGN.EQ.ICHAR('+')) GOTO 805
 983 C     C0M(4)=IBCLR(C0M(4),14)
 984 C     GOTO 10
 985 C 805 C0M(3)=IBSET(C0M(3),14)
 986 C     GOTO 10
 987 cdeb  added
 988 C  ROZPOZNANO 'S'
 989   830 IF (SIGN.EQ.ICHAR('+')) GOTO 835
 990       C0M(4)=IBCLR(C0M(4),13)
 991       GOTO 10
 992   835 C0M(3)=IBSET(C0M(3),13)
 993       GOTO 10
 994 cdeb
 995 C  ROZPOZNANO 'T'
 996 840   IF (SIGN.EQ.ICHAR('+')) GOTO 845
 997       C0M(4)=IBCLR(C0M(4),3)
 998       GOTO 10
 999 845   C0M(3)=IBSET(C0M(3),3)
1000       GOTO 10
1001 9999  C0M(2)=IOR(C0M(3),IAND(C0M(4),C0M(2)))
1002
1003       call ffputnl(0)
1004       call ffputcs(0,' Pass One')
1005       call ffputnl(0)
1006       call ffputnl(0)
1007
1008       RETURN
1009       END
1010
1011       SUBROUTINE  MESS
1012 C----------------DISPLAYS END-OF-PASS INFORMATION
1013       IMPLICIT INTEGER (A-Z)
1014 C
1015 #include "blank.h"
1016       COMMON /MJLMSG/ IERC, MSG
1017       integer*4 msg
1018 C ---
1019       IOP(1) = IOP(1)+1
1020       IF (IERC .EQ. 0) RETURN
1021 C ---
1022       IF (IOP(1).LE.7) RETURN
1023 C ---
1024       END
1025