sources/pass1/scan.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       SUBROUTINE SCAN
  17       IMPLICIT INTEGER (A-Z)
  18       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
  19       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
  20       COMMON /BLANK/
  21      $   C0M(4),
  22      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
  23      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
  24      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
  25      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
  26      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
  27      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
  28      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
  29      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
  30      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
  31      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
  32      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
  33      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
  34      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
  35      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
  36      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
  37      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
  38      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
  39      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
  40
  41       common /BLANK/
  42      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
  43      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
  44      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
  45      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
  46      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
  47      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
  48      N   COM(132),
  49      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
  50      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
  51      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
  52      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
  53      S   HASH(8000), M,        NAME(10), NLAST,    NL,
  54      T   KEYS(200),
  55      U   TRANS1(13,13),      TRANS2(13,13),      B0,       B(70),
  56      V   SKOK0,    SKOK(70), KK,       MM,       STAN,     STAN1,
  57      W   AUX,      K1,       SY,       SY1,      NU, JK1,  EXP,
  58      X   SIGN,     INTPART,  FRAC,     OKEY,     FRACT,JK2,NB,
  59      Y   TL,       BYTE,     TEXT(20),
  60      Z   TOP,      IN,       NEXT,     STACK(500)
  61
  62       common /BLANK/
  63      *   RESZTA(3652)
  64
  65       REAL   FRACT,NU
  66 cdsw&bc
  67       logical overfl
  68       LOGICAL OK,OKEY
  69       INTEGER SD,SE,SL,SR,SS,ST
  70       data sd,se,sl,sr,ss,st /2,61,40,41,47,42/
  71       DATA SCANHEX /x'7FFF'/
  72 C
  73       overfl = .FALSE.
  74       OK=.FALSE.
  75       IF (.NOT.OKEY) GOTO 111
  76       K=K1
  77       IF (SY.EQ.70) GOTO 3001
  78 C        INSERTED DUE TO T.SZCZEPANEK
  79       SY=SY1
  80       OKEY=.FALSE.
  81       GOTO 2000
  82 101   CALL ERROR(111)
  83       LP=LP+1
  84 111   IF (LP.LT.MAX) GOTO 1
  85       CALL READIN
  86 1     IF (BUFOR(1).EQ.SD) GOTO 3001
  87       Z=BUFOR(LP)
  88       ZNAK=ORD(Z)
  89 C  ZNAK MEANS CHARACTER
  90       IF (STAN.LT.10) GOTO 10
  91 C  WITHIN COMMENT - COMPOUND SYMBOLS ARE NOT PICKED UP
  92 C  THE SAME FOR TEXT AND CHARACTER CONSTANTS
  93       IF (STAN.EQ.11) GOTO 11
  94       GOTO 8
  95 10    IF (ZNAK.EQ.63) GOTO 101
  96 11    I=SKOK(ZNAK)
  97       GOTO (2,3,4,5,6,8),I
  98 2     IF (BUFOR(LP+1).NE.SE) GOTO 8
  99       GOTO 7
 100 3     IF (BUFOR(LP+1).NE.SR) GOTO 8
 101       GOTO 7
 102 4     IF (BUFOR(LP+1).NE.SS) GOTO 8
 103       IF (BUFOR(LP+2).NE.SE) GOTO 8
 104       LP=LP+1
 105       GOTO 7
 106 C --- ALLOW FOR "<>" TO STAND FOR "NON EQUAL"
 107 5     IF (ZNAK.NE.50) GO TO 5055
 108       IF (BUFOR(LP+1) .NE. ICHAR('>')) GO TO 5055
 109       ZNAK = 49
 110       GO TO 7
 111 C ---
 112 5055  IF (BUFOR(LP+1).NE.SE) GOTO 8
 113       GOTO 7
 114 6     IF (BUFOR(LP+1).NE.ST) GOTO 8
 115 C  BEGINNING OF COMMENT HAS BEEN RECOGNIZED '(*'. CHECK FOR A LISTING
 116 C  CONTROL OPTION FOLLOWING THE COMMENT ANNOUNCEMENT. IF ONE OCCURRS
 117 C  THEN THE LISTING CONTROL VARIABLE IS TO BE SET PROPERLY
 118       IF (BUFOR(LP+2).NE.ICHAR('$')) GOTO 7
 119       LP=LP+3
 120       CALL OPTSET
 121 7     LP=LP+1
 122       ZNAK=ZNAK+7
 123 8     LP=LP+1
 124 C  END OF DETECTING COMPOUND SYMBOLS
 125 C  THE AUTOMATON - PART I
 126       J=B(ZNAK)+1
 127       I=TRANS1(J,STAN+1)
 128       GOTO (190,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,170,
 129      ,180),I
 130 20    SY=SEARCH(MM)
 131       K=0
 132       KLUCZ=KEY(SY)
 133       IF (KLUCZ.EQ.(SIDENT*8)) K=2
 134       K=K/2
 135       OK=.TRUE.
 136       GOTO 190
 137 30    IF (KK.LT.NB) GOTO 31
 138       IF (MM.LT.TL) GOTO 32
 139       CALL ERROR(212)
 140       GOTO 190
 141 31    KK=KK+1
 142 cbc   COM(MM)=ISHFT(COM(MM),8)+Z
 143       com(mm)=ior(ishft(z, 8), com(mm))
 144 cbc
 145       GOTO 190
 146 32    KK=1
 147       MM=MM+1
 148       com(MM)=Z
 149       GOTO 190
 150 40    IF (KK.LT.NB) GOTO 41
 151       IF (MM.LT.NL) GOTO 42
 152       CALL ERROR(211)
 153       GOTO 190
 154 41    KK=KK+1
 155       NAME(MM)=NAME(MM)*BYTE+ZNAK
 156       GOTO 190
 157 42    KK=1
 158       MM=MM+1
 159       NAME(MM)=ZNAK
 160       IF (ZNAK.EQ.0) NAME(MM)=60
 161       GOTO 190
 162 50    K=2
 163 cdsw&bc      IF (INTPART.LT.0) GOTO 52
 164       if (overfl) goto 52
 165       SY=INTPART
 166       GOTO 53
 167 52    SY=SCANHEX
 168       CALL ERROR(205)
 169 53    INTPART=0
 170       OK=.TRUE.
 171       GOTO 190
 172 70    CALL ERROR(201)
 173 60    IF (SIGN.EQ.1) EXP=-EXP
 174       EXP=EXP-FRAC
 175 cdsw&bc      IF (INTPART.LT.0) GOTO 191
 176       if (overfl) goto 191
 177       FRACT=INTPART
 178       GOTO 192
 179 191   FRACT=NU
 180 192   IF (EXP) 200,210,193
 181 193   DO 195 J=1,EXP
 182 CJF      IF (FRACT.GT.0.7237005E75) GOTO 207
 183 195   FRACT=FRACT*10.0
 184       GOTO 210
 185 CJF 207   CALL ERROR(206)
 186 CJF       GOTO 210
 187 200   EXP=-EXP
 188       DO 205 J=1,EXP
 189 CJF      IF (FRACT.GT.0.AND.FRACT.LT.0.5397605E-77) GOTO 207
 190 205   FRACT=FRACT*0.1
 191 210   K=4
 192       NU=FRACT
 193       OK=.TRUE.
 194       SIGN=0
 195       EXP=0
 196       INTPART=0
 197       FRAC=0
 198       GOTO 190
 199 80    K=6
 200       SY=38
 201       OK=.TRUE.
 202       GOTO 190
 203 90    INTPART=ZNAK
 204       GOTO 190
 205 110   FRAC=0
 206 130   FRAC=FRAC+1
 207 cdsw&bc 100   IF (INTPART.LT.0) GOTO 102
 208 100   if (overfl) goto 102
 209       NU=INTPART
 210 cdsw&bc check for overflow
 211 #if ( WSIZE == 4 )
 212 cailvaxC  max. integer on VAX is 2147483647
 213       if ( (intpart .gt. 214748364) .or. ((intpart .eq. 214748364)
 214      C    .and. (znak .gt. 7)) ) overfl = .TRUE.
 215       if (overfl) goto 102
 216 #else
 217       if (intpart .gt. 3275) overfl = .TRUE.
 218 #endif
 219       INTPART=INTPART*10+ZNAK
 220 cdsw&bc   IF (INTPART.GE.0) GOTO 190
 221 #if ( WSIZE == 4 )
 222 cailvaxC   overfl is .FALSE. here
 223       goto 190
 224 #else
 225       if (.not. overfl) goto 190
 226 #endif
 227 102   NU=NU*10.0+ZNAK
 228       GOTO 190
 229 120   EXP=ZNAK
 230       GOTO 190
 231 140   EXP=EXP*10+ZNAK
 232       GOTO 190
 233 150   SIGN=1
 234       GOTO 190
 235 160   STAN1=STAN
 236       GOTO 190
 237 170   CALL ERROR(202)
 238       GOTO 190
 239 180   IF (EXP.LT.0) GOTO 181
 240       IF (ZNAK.EQ.44) GOTO 190
 241       ZNAK=36
 242       STAN=0
 243 cdsw&bc
 244       exp = 0
 245 c
 246       CALL ERROR(203)
 247       GOTO 190
 248 181   EXP=Z
 249       ZNAK=0
 250 190   CONTINUE
 251 C  THE AUTOMATON - PART II
 252 1000  J=B(ZNAK)+1
 253       I=TRANS2(J,STAN+1)
 254       GOTO (1300,1020,1030,1040,1050,1060,1070,1080,1090,1100,1110,1120,
 255      ,1130,1140,1150,1160,1170,1180,1190,1200,1210),I
 256 1020  STAN=0
 257       GOTO 1300
 258 1030  KK=1
 259       MM=1
 260       NAME(1)=ZNAK
 261       STAN=1
 262       GOTO 1300
 263 1040  KK=2
 264       MM=1
 265       NAME(1)=14*BYTE+ZNAK
 266       STAN=1
 267       GOTO 1300
 268 1050  STAN=2
 269       GOTO 1300
 270 1060  STAN=5
 271       GOTO 1300
 272 1070  STAN=9
 273       GOTO 1300
 274 1080  STAN=8
 275       GOTO 1300
 276 1090  STAN=3
 277       GOTO 1300
 278 1100  SY=ZNAK
 279       GOTO 2070
 280 1110  STAN=4
 281       GOTO 1300
 282 1120  CALL ERROR(204)
 283 1130  STAN=6
 284       GOTO 1300
 285 1140  IF (OK) GOTO 1145
 286       STAN=0
 287       SY=ZNAK
 288       GOTO 2070
 289 1145  K1=6
 290       SY1=ZNAK
 291       STAN=0
 292       OKEY=.TRUE.
 293       GOTO 1300
 294 1150  STAN=7
 295       GOTO 1300
 296 1160  KK=2
 297       MM=1
 298 cdsw&bc
 299       com(2) = 0
 300 c
 301       STAN=10
 302       GOTO 1300
 303 1170  STAN=0
 304       K=4
 305       S=SCONST
 306       CALL TINSER
 307       GOTO 3000
 308 1180  STAN=11
 309       GOTO 1300
 310 1190  STAN=STAN1
 311       GOTO 1300
 312 1200  STAN=12
 313       EXP=-1
 314       GOTO 1300
 315 1210  K=6
 316       STAN=0
 317       S=SCONST
 318       ADRES=EXP
 319        EXP=0
 320       GOTO 3000
 321 1300  CONTINUE
 322 C  END OF THE SECOND PHASE
 323       IF (.NOT.OK) GOTO 111
 324 2000  K=K+1
 325       GOTO (2010,2020,2030,2040,2050,2060,2070),K
 326 2010  K=KLUCZ
 327       S=K/8
 328       ADRES=1+MOD(K,8)
 329       K=SY
 330       GOTO 3000
 331 2020  S=SIDENT
 332       ADRES=SY
 333       GOTO 3000
 334 2030  S=SCONST
 335 C  INTEGER CONSTANT RECOGNIZED
 336       ADRES=SY
 337 cdsw
 338       sy = 0
 339       GOTO 3000
 340 2040  S=SCONST
 341       CALL TINSER
 342       GOTO 3000
 343 2050  S=SCONST
 344       ADRES=EMBEDE(NU)
 345       GOTO 3000
 346 2060  S=SCONST
 347       ADRES=EXP
 348       GOTO 3000
 349 2070  K=SY-37
 350       GOTO (2150,2102,2103,2104,2150,2150,2150,2150,2150,2150,2105,2106,
 351      ,2107,2108,2150,2150,2150,2150,2109,2110,2111),K
 352 2102  S=STAR
 353       ADRES=3
 354       GOTO 3000
 355 2103  S=STAR
 356       ADRES=4
 357       GOTO 3000
 358 2104  S=STAR
 359       ADRES=6
 360       GOTO 3000
 361 2105  S=STAR
 362       ADRES=5
 363       GOTO 3000
 364 2106  S=SRELAT
 365       ADRES=3
 366       GOTO 3000
 367 2107  S=SRELAT
 368       ADRES=5
 369       GOTO 3000
 370 2108  S=SRELAT
 371       ADRES=7
 372       GOTO 3000
 373 2109  S=SRELAT
 374       ADRES=4
 375       GOTO 3000
 376 2110  S=SRELAT
 377       ADRES=6
 378       GOTO 3000
 379 2111  S=SRELAT
 380       ADRES=8
 381       GOTO 3000
 382 2150  S=SY
 383 3000  CONTINUE
 384       RETURN
 385 3001  K=6
 386       S=70
 387       OKEY=.TRUE.
 388       SY1=70
 389 C     THE LAST TWO STATEMENT ARE INSERTED DUE TO T.SZCZEPANEK
 390       RETURN
 391       END
 392
 393       SUBROUTINE READIN
 394       IMPLICIT INTEGER (A-Z)
 395       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
 396 C
 397 C  POSTR - BUFFER FOR AUXILIARY INPUT FILE
 398 C  VARIABLE STATUS DESCRIBES THE STATUS OF INPUT:
 399 C    1 - SOURCE TEXT IS READ FROM THE AUXILIARY INPUT
 400 C    0 - SOURCE TEXT IS READ FROM THE STANDARD INPUT
 401 C   -1 - SOURCE TEXT HAS BEEN READ UNTIL THE LAST END. NOW THE STANDARD
 402 C        INPUT IS BEING SKIPPED UNTIL EOF
 403 C
 404       COMMON /LISTING/ OUTSTR(265)
 405       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
 406       COMMON /BLANK/ C0M(4)
 407       LOGICAL BTEST
 408       character*1 bufor1(85)
 409       character int2char
 410       integer bufor2(43)
 411       equivalence (bufor1(1), bufor2(1))
 412
 413       I=1
 414       LP=1
 415         GOTO 2
 416 C  NOW ONE LINE IS READ FROM THE INPUT FILE
 417 1     LN=LN+1
 418       call ffwrhex(16, ln)
 419 c
 420       IF (BTEST(C0M(2),15)) GOTO 1001
 421       call ffwrite_char(16, '0')
 422 c
 423       GOTO 1002
 424 1001  call ffwrite_char(16, '1')
 425 c
 426 1002  CONTINUE
 427 c end of line - write CR/LF
 428       call ffwrite_char(16, int2char(13))
 429       call ffwrite_char(16, int2char(10))
 430 2     call nextch(17, bufor(1))
 431       bufor(1) = iand(X'FF',bufor(1))
 432       IF (BUFOR(1).EQ.1) GOTO 1
 433       IF (BUFOR(1).EQ.2) RETURN
 434 3     I=I+1
 435       call nextch(17, bufor(i))
 436       bufor(i) = iand(X'FF',bufor(i))
 437       if (bufor(i) .eq. 1) goto 90
 438       if (i .lt. 84) goto 3
 439       max = i
 440       goto 100
 441 90    max = i-1
 442 100   continue
 443       LN=LN+1
 444       call ffwrhex(16, ln)
 445 c
 446       IF (BTEST(C0M(2),15)) GOTO 110
 447       call ffwrite_char(16, '0')
 448 c
 449       GOTO 115
 450 110   call ffwrite_char(16, '1')
 451 c
 452 115   CONTINUE
 453       BUFOR(max+1)=1
 454       do 120 i=1,max
 455 120   bufor1(i) = char(bufor(i))
 456       call ffwrite(16, bufor2(1), max)
 457 c
 458       call ffwrite_char(16, int2char(13) )
 459       call ffwrite_char(16, int2char(10) )
 460       DO 140 I=MAX+1,85
 461 140   BUFOR(I)=ICHAR(' ')
 462       MAX=MAX+2
 463       RETURN
 464       END
 465
 466       SUBROUTINE ERROR(K)
 467 C   LIS OF THE ERRORS DIAGNOSED BY THE PARSER
 468 C
 469 C   101 - :=              EXPECTED
 470 C   102 - ;                   "
 471 C   103 - 'THEN'              "
 472 C   104 - 'FI', 'ELSE'        "
 473 C   105 - 'OD'                "
 474 C   106 - (                   "
 475 C   107 - )                   "
 476 C   108 - 'DO'                "
 477 C   109 - IDENTIFIER          "
 478 C   110 - TOO MANY EXIT-S
 479 C   111 - ILLEGAL CHARACTER
 480 C   112 - STRUCTURE ERROR IN 'IF THEN ELSE FI'
 481 C   113 - ????????????????????????????????????????????????
 482 C   114 - DOT MISSING
 483 C   115 - WRONG OCCURRENCE OF A CONSTANT IN EXPRESSION
 484 C   116 -  =              MISSING
 485 C   117 -  CONSTANT       MISSING
 486 C   118 -  DELIMITER      MISSING
 487 C   119 - CLASS/ PROCEDURE / FUNCTION    EXPECTED
 488 C   120 - 'HIDDEN HIDDEN' OR 'CLOSE CLOSE'
 489 C   121 - HIDDEN OUTSIDE CLASS
 490 C   122 - 'BLOCK' MISSING
 491 C   123 - OBJECTEXPRESSION IS NOT A GENERATOR
 492 C   124 - 'DIM'                MISSING
 493 C   125 - 'TO' / 'DOWNTO'      MISSING
 494 C   126 - ILLEGAL OCCURRENCE OF AN ARITHMETIC OPERATOR
 495 C   127 - DECLARATIONS EXPECTED (UNIT, VAR, CONST)
 496 C   128 - THE NAME OCCURRING AFTER 'END' DOESN-T MATCH THE UNIT NAME
 497 C   129 - CASE...ESAC STRUCTURE ERROR
 498 C   130 - DO...OD STRUCTURE ERROR
 499 C   131 - ILLEGAL OCCURRENCE OF MAIN
 500 C   132 - WHEN EXPECTED
 501 C   133 - TOO MANY CASES IN 'CASE' (UPPER LIMIT = 127)
 502 C   134 - 'BEGIN' MISSING
 503 C   135 - ERROR IN OPTION DEFINITON IN COMMENT
 504 C   136 - NULL PROGRAM
 505 C   137 - WRONG HEADER OF THE SOURCE PROGRAM (BLOCK/PROGRAM MISSING)
 506 C   138 - TOO MANY REPEAT STATEMENTS
 507 C   139 - UNREACHABLE INSTRUCTIONS AFTER EXIT
 508 C   140 - ANDIF'S AND ORIF'S INTERLEAVE
 509 C   141 - SEMAPHORE TYPE PRECEDED BY ARRAYOF
 510 C   142 - HANDLER IMPROPERLY ENDED
 511 C   143 - LASTWILL OCCURRS WITHIN A COMPOUND STATEMENT OR WITHIN A HANDLER
 512 C   144 - LASTWILL OCURRS TWICE
 513 C   145 - NO PARAMETER SPECIFICATION
 514 C   146 - WRONG REGISTER SPECIFICATION (IMPOSSIBLE IN THE PORTABLE VERSION)
 515 C   147 -
 516 C         OVERFLOW-TYPE ERRORS: SCANNING STOPS ON ANY OF THEM
 517 C   191 - NULL PROGRAM - THE INPUT FILE IS EMPTY
 518 C   196 - HASH TABLE OVERFLOW
 519 C   197 - VARIABLE OR FORMAL PARAMETER LIST TOO LONG (LENGTH>132)
 520 C   198 - PARSER STACK OVERFLOW
 521 C   199 - IPMEM TABLE OVERFLOW - NO ROOM FOR MORE PROTOTYPES
 522 C         SCANNER ERRORS:
 523 C   201 - ERROR IN REAL CONSTANT
 524 C   202 - COMMENT STRUCTURE ERROR
 525 C   203 - ERROR IN CHARACTER CONSTANT
 526 C   204 - ERROR IN CONSTANT
 527 C   205 - VALUE OF A INTEGER CONSTANT EXCEEDS MACHINE ARITHMETIC
 528 C   206 -            REAL
 529 C   211 - IDENTIFIER TOO LONG (INITIAL 20 CHARACTERS ARE SIGNIFICANT)
 530 C   212 - TEXT TOO LONG (INITIAL 264 CHARACTERS ARE SIGNIFICANT)
 531       IMPLICIT INTEGER (A-Z)
 532       COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
 533       COMMON /LISTING/ OUTSTR(265)
 534       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
 535       COMMON /BLANK/  C0M(4) , S , ADRES , KA , RESZTA(8185)
 536       LOGICAL BTEST
 537       character int2char
 538       DATA EL,EP /0,0/
 539
 540       IF ((EL.EQ.LN).AND.(EP.GE.LP-1)) GOTO 15
 541       call ffwrhex(16, ln)
 542 c
 543       IF (BTEST(C0M(2),15)) GOTO 1
 544       call ffwrite_char(16, '0')
 545 c
 546       GOTO 2
 547 1     call ffwrite_char(16, '1')
 548 c
 549 2     CONTINUE
 550       IF (LP.LT.3) GO TO 6
 551       DO 5 I=3,LP
 552 5     call ffwrite_char(16, ' ')
 553 6     CONTINUE
 554       call ffwrite_char(16, '?')
 555       call ffwrint(16, k)
 556 c end of line - write CR/LF
 557       call ffwrite_char(16, int2char(13) )
 558       call ffwrite_char(16, int2char(10) )
 559 c
 560       LINE=LN
 561       IF ((K.GT.190).AND.(K.LT.200)) CALL OVERF(K)
 562       CALL MERR(K,0)
 563 15    EP=LP
 564       EL=LN
 565       RETURN
 566       END
 567
 568       INTEGER FUNCTION ORD(X)
 569       IMPLICIT INTEGER (A-Z)
 570 cdsw    BYTE TAB(122)
 571       dimension tab(122)
 572 C --- ORIGINAL TABLE (FOR ISO-7 CODE) CHANGED TO WORK FOR EBCDIC
 573         DATA TAB /8*63,36,3*63,37,19*36,63,43,4*63,44,52,53,48,39,
 574      ,42,40,38,41,0,1,2,3,4,5,6,7,8,9,47,45,50,49,51,63,63,
 575      ,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,
 576      ,30,31,32,33,34,35,4*63,46,
 577      ,63,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,
 578      ,30,31,32,33,34,35/
 579       Z=X
 580       IF (Z.GT.122) GOTO 10
 581       ORD=TAB(Z)
 582         RETURN
 583 10      ORD = 63
 584         RETURN
 585       END
 586
 587       INTEGER FUNCTION SEARCH(K)
 588       IMPLICIT INTEGER (A-Z)
 589       COMMON /BLANK/ COM(302),
 590      1  HASH(8000),  M,  NAME(10),  NLAST,  NL,
 591      2  KEYS(200),
 592      3  SCANER(522),  STOS(503),  RESZTA(3652)
 593
 594       NAME1=NAME(1)
 595       I=MOD(NAME1,M)
 596       I=I*2+1
 597       IF (HASH(I).NE.0) GOTO 3
 598       SEARCH=I
 599       HASH(I)=NAME1
 600       GOTO 11
 601 1     IF (I.NE.0) GOTO 3
 602 2     NLAST=NLAST-2
 603       IF (NLAST.LT.0) CALL ERROR(196)
 604       IF (HASH(NLAST).NE.0) GOTO 2
 605       SEARCH=NLAST
 606       HASH(NLAST)=NAME(1)
 607       HASH(J+1)=NLAST
 608       I=NLAST
 609       GOTO 11
 610 3     IF (HASH(I).EQ.NAME1) GOTO 4
 611       J=I
 612       I=HASH(J+1)
 613       GOTO 10
 614 4     IF ((K.NE.1).OR.(HASH(I+1).LT.0)) GOTO 5
 615       SEARCH=I
 616       RETURN
 617 5     J=I
 618       P=1
 619 6     T=HASH(J+1)
 620       P=P+1
 621       IF (P.LE.K) GOTO 8
 622       IF (T.LT.0) GOTO 7
 623       SEARCH=I
 624       RETURN
 625 7     J=-T
 626       I=HASH(J+1)
 627       GOTO 10
 628 8     IF (T.LT.0) GOTO 9
 629       I=T
 630       GOTO 1
 631 9     J=-T
 632       IF (NAME(P).EQ.HASH(J)) GOTO 6
 633       I=HASH(J+1)
 634 10    IF (I.GE.0) GOTO 1
 635       J=-I
 636       I=HASH(J+1)
 637       GOTO 10
 638 11    P=2
 639 12    IF (P.GT.K) RETURN
 640 13    NLAST=NLAST-2
 641       IF (NLAST.LT.0) CALL ERROR(196)
 642       IF (HASH(NLAST).NE.0) GOTO 13
 643       HASH(NLAST)=NAME(P)
 644       HASH(I+1)=-NLAST
 645       I=NLAST
 646       P=P+1
 647       GOTO 12
 648       END
 649
 650       INTEGER FUNCTION EMBEDE(X)
 651 C --- NAME CHANGED TO AVOID CONFLICTS IN THE 'ONE-PROGRAM' VERSION
 652 C --- OF THE COMPILER
 653       IMPLICIT INTEGER(A-Z)
 654       COMMON /BLANK/ COM(278),
 655      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 656      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 657      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 658      X        LOCAL , OWN   , OBJECT,
 659      x        ipmem(12890)
 660 cdsw X        IPMEM(7890)
 661       LOGICAL  INSYS, LOCAL, OWN
 662 C  IPMEM - MAIN MEMORY
 663 C  ISFIN - TOP OF THE PROTOTYPE DICTIONARY STACK
 664 C  LPMEM - DIVISION POINT OF IPMEM
 665       REAL   X, STALE(200)
 666       EQUIVALENCE (IPMEM(1), STALE(1))
 667
 668 #if ! ( WSIZE == 4 )
 669       real y
 670       integer*2 m(2)
 671       equivalence (y, m(1))
 672 #endif
 673
 674       EMBEDE = 1
 675
 676 #if ( WSIZE == 4 )
 677 cvax one real constant in one ipmem element (4 bytes)
 678       i = lpmem-1
 679       goto 10
 680 5     i = i+1
 681       if (stale(i).eq.x) goto 20
 682 10    if (i+1.lt.lpml) goto 5
 683       if (lpml+1.gt.lpmf) goto 300
 684       i = lpml
 685       lpml=lpml+1
 686       stale(i) = x
 687 20    embede = i
 688 #else
 689 C --- LENGTH OF REALS ON SIEMENS IS 2
 690       y = x
 691       i = lpmem-2
 692       goto 10
 693 5     i = i + 2
 694       if (ipmem(i) .eq. m(1) .and. ipmem(i+1) .eq. m(2)) go to 20
 695 10    if (i+2 .lt. lpml) go to 5
 696       if (lpml+2 .gt. lpmf) go to 300
 697       i = lpml
 698       lpml = lpml + 2
 699       ipmem(i  ) = m(1)
 700       ipmem(i+1) = m(2)
 701 20    embede = (i+1) / 2
 702 #endif
 703       return
 704
 705 300   CALL ERROR(199)
 706       RETURN
 707       END
 708
 709
 710       SUBROUTINE TINSER
 711       IMPLICIT INTEGER (A-Z)
 712       COMMON /BLANK/
 713      $   C0M(4),
 714      O   S,        ADRES,    K,        SCOMA,    SDOT,     SEMICOL,
 715      1   SCOLON,   SLEFT,    SRIGHT,   SBECOME,  STAR,     SRELAT,
 716      2   SEOF,     SIDENT,   SCONST,   SAND,     SARRAY,   SARROF,
 717      3   SATTACH,  SBEGIN,   SBLOCK,   SBOOL,    SCALL,    SCASE,
 718      4   SCLASS,   SCLOSE,   SCONS,    SCOPY,    SCOROUT,  SDETACH,
 719      5   SDIM,     SDO,      SDOWN,    SELSE,    SEND,     SESAC,
 720      6   SEXIT,    SEXTERN,  SFI,      SFOR,     SFUNCT,   SIF,
 721      7   SINNER,   SINPUT,   SINT,     SKILL,    SLOCK,    SNEW,
 722      8   SNONE,    SNOT,     SOD,      SOR,      SORIF,    SOTHER,
 723      9   SOUTPUT,  SPREF,    SPRCD,    SQUA,     SREAD,    SRESUME,
 724      O   SRETURN,  STEP,     STOP,     STAKEN,   STHEN,    STHIS,
 725      A   STO,      STYPE,    SUNIT,    SVAR,     SVIRTUAL, SWAIT,
 726      B   SWHEN,    SWHILE,   SWRIT,    SWRITLN,  STRUE,    SALL,
 727      C   WAND,     WARRAY,   WASSIGN,  WASSCON,  WATTACH,  WBLOCK,
 728      D   WCALL,    WCASE,    WCASEL,   WCOMA,    WCNSTB,   WCNSTC,
 729      E   WCNSTI,   WCNSTN,   WCNSTR,   WCNST,    WCOPY,    WDETACH,
 730      F   WDOT,     WDOWNTO,  WEOF,     WESAC,    WFIN,     WFIRST,
 731      G   WFOREND,  WFORVAR,  WFROM,    WIDENT,   WIFFALS,  WIFTRUE
 732
 733       common /BLANK/
 734      H   WINNER,   WINSTREND,WJUMP,    WKILL,    WLABEL,   WLEFT,
 735      I   WLOCK,    WLOW,     WLSE,     WNEW,     WNEWARRAY,WNOT,
 736      J   WOPERAT,  WOPT,     WOR,      WOTHER,   WPREF,    WPRIM,
 737      K   WQUA,     WREAD,    WRELAT,   WRESUME,  WRETURN,  WRIGHT,
 738      L   WSTART,   WSTEP,    WSTOP,    WTHIS,    WTO,      WAIT,
 739      M   WRITE,    WRITELN,  WBOUND,   UNICAL,
 740      N   COM(132),
 741      O   LMEM,     LPMEM,    IRECN,    ISFIN,    LPMSYS,   LPML,
 742      P   LPMF,     NRINT,    NRRE,     NRBOOL,   NRCHAR,   NRCOR,
 743      Q   NRPROC,   NRTEXT,   NRUNIV,   NATTR,    NRNONE,   NBLSYS,
 744      R   NBLUS,    NEMPTY,   INSYS,    LOCAL,    OWN,      OBJECT,
 745      S   HASH(8000), M,      NAME(10), NLAST,    NL,
 746      T   KEYS(200),
 747      U   TRANS1(13,13),      TRANS2(13,13),      B0,       B(70),
 748      V   SKOK0,    SKOK(70), KK,       MM,       STAN,     STAN1,
 749      W   AUX,      K1,       SY,       SY1,      NU, JK1,  EXP,
 750      X   SIGN,     INTPART,  FRAC,     OKEY,     FRACT,JK2,NB,
 751      Y   TL,       BYTE,     TEXT(20),
 752      Z   TOP,      IN,       NEXT,     STACK(500)
 753
 754       common /BLANK/
 755      *   RESZTA(3652)
 756       REAL   FRACT,NU
 757       COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
 758      X                POSIT,RECNR,NEKST
 759       LOGICAL ERRFLG
 760       logical btest
 761       character int2char
 762
 763       integer zero(2)
 764       character stringbuffer(2)
 765       integer istringbuffer(1)
 766       equivalence (stringbuffer(1),istringbuffer(1))
 767 cvax
 768       character zeroc(8)
 769       equivalence (zero(1), zeroc(1))
 770 c
 771       data zero /0, 0/
 772 cbc
 773       ADRES=0
 774       IF (ERRFLG) RETURN
 775       IF (COM(2).EQ.0) RETURN
 776       ADRES=TEXT(1)
 777       LENGTH=2*MM-2
 778       IF (COM(MM).LT.256) LENGTH=LENGTH-1
 779 c write string length (in bytes)
 780       call ffwrite_ints(15, length, 1)
 781 c write string itself without any padding
 782       l = length / 2
 783 cdsw - poprawka na wszelki wypadek
 784       if (l.eq.0) goto 101
 785 c
 786       do 100 i = 1, l
 787       stringbuffer(1)=int2char(iand(com(1+i),X'FF'))
 788       stringbuffer(2)=int2char(ishft(com(1+i),-8))
 789 100   call ffwrite(15,istringbuffer(1),2)
 790 101   continue
 791       if (mod(length, 2) .ne. 1)  goto 102
 792       stringbuffer(1)=int2char(iand(com(2+l),X'FF'))
 793       call ffwrite(15, istringbuffer(1), 1)
 794 102   continue
 795
 796 c compute the number of trailing zero bytes
 797 #if ( WSIZE == 4 )
 798       wrdsiz = 4
 799 #else
 800       wrdsiz=2
 801       if (btest(c0m(2), 12)) wrdsiz=4
 802 #endif
 803
 804       fill=wrdsiz-mod(length, wrdsiz)
 805 c and write them
 806       call ffwrite(15, zero, fill)
 807 c compute next string address
 808       text(1) = text(1) + 1 + (length+fill)/wrdsiz
 809       RETURN
 810       END
 811
 812       INTEGER FUNCTION KEY ( ADR )
 813
 814 C
 815 C   COMPUTES KEY OF THE ENCOUNTERED WORD. IT-S ADDRESS IS PASSED THRU
 816 C   ADR.
 817 C
 818 C   STRUCTURE OF KEY TABLE:
 819 C
 820 C         KEYS(2*N)   - ADDRESS OF A KEYWORD
 821 C         KEYS(2*N-1) - KEY OF THIS WORD
 822 C
 823 C   NOTE:  FOR THE WORDS THAT DO NOT OCCUR IN THE DICTIONARY
 824 C          THE FUNCTION RETURNS IDENTIFIER KEYS
 825 C
 826       IMPLICIT INTEGER (A-Z)
 827       COMMON /BLANK/ C0M(146),COM(132),XX(8037),KEYS(200),RESZTA(4677)
 828 C --- SPECIAL CHECK IS MADE HERE FOR THE ENTRIES WHICH ARE MISSING
 829 C --- IN THE HASH TABLE AND IN 'KEYS'
 830 C
 831 C --- READLN
 832       IF (ADR.NE.1833) GO TO 9999
 833       KEY = 256
 834       RETURN
 835 C --- END OF CHECK FOR MISSING KEYS
 836 c   get
 837 9999  if(adr.ne.59) go to 9998
 838       key = 249
 839       return
 840 c   put
 841 9998  if(adr.ne.1243) go to 9997
 842       key = 248
 843       return
 844 c  file
 845 9997  if(adr.ne.2339) go to 9996
 846       key = 518
 847       return
 848 c   open
 849 9996  if(adr.ne.2347) go to 9995
 850       key = 240
 851       return
 852 c   eof
 853 9995  if(adr.ne. 1841) go to 9994
 854       key = 480
 855       return
 856 c   eoln
 857 9994  if(adr.ne.2579) go to 9993
 858       key = 481
 859       return
 860 c   text - key jak dla string
 861 9993  if(adr.ne.2249) go to 9992
 862       key = 517
 863       return
 864 c  direct - klasa 64/7 - jak dla typow pierwotnych
 865 9992  if (adr .ne. 2097) goto 8888
 866       key = 519
 867       return
 868 c  putrec - klasa 34/0
 869 8888  if (adr .ne. 2075) goto 8889
 870       key = 272
 871       return
 872 c  getrec - klasa 34/1
 873 8889  if (adr .ne. 2081) go to 8890
 874       key = 273
 875       return
 876 cbc    ----- added concurrent statements
 877 c  enable - klasa 35/0
 878 8890  if (adr .ne. 2047) goto 8891
 879       key = 280
 880       return
 881 c  disable - klasa 35/1
 882 8891  if (adr .ne. 2041) goto 8892
 883       key = 281
 884       return
 885 c  accept - klasa 36/0
 886 8892  if (adr .ne. 2053) goto 8893
 887       key = 288
 888       return
 889 cbc   -----------  end
 890 c    break
 891 8893  if(adr.ne.1463) go to 9991
 892       key = 264
 893       return
 894 9991  CONTINUE
 895       KEY=1*8
 896       LEFT=1
 897       RIGHT=COM(1)
 898       IF (KEYS(2*LEFT)-ADR) 30,20,10
 899 10    RETURN
 900 20    POINT=LEFT
 901       GOTO 200
 902 30    IF (KEYS(2*RIGHT)-ADR) 10,40,50
 903 40    POINT=RIGHT
 904       GOTO 200
 905 50    POINT=(LEFT+RIGHT)/2
 906       IF (KEYS(2*POINT)-ADR) 100,200,300
 907 100   IF (LEFT.EQ.POINT) RETURN
 908       LEFT=POINT
 909       GOTO 50
 910 200   KEY=KEYS(2*POINT-1)
 911       RETURN
 912 300   RIGHT=POINT
 913       GOTO 50
 914       END
 915