programs/fortran/src/frtn_2_of_5.asm

   1 *                       TAPE 2 OF 5 - BEGIN
   2 *
   3 DN63    CRA             IM = 0
   4         STA     IM
   5         JMP     DN67    GO TO DN67 (18)
   6 DN64    LDA     K101
   7         STA     TID
   8 DN66    LDA     K101
   9         STA     NT      NAME TAG = 1 (CONSTANT)
  10         LDA     K102    IU=VAR
  11         STA     IU
  12         LDA     K103
  13         STA     IM      IM = LOG
  14         JST     CH00
  15 DN67    JST     FN00    FINISH OPERATOR
  16 DN68    LDA     F6      IF F6 = 0,
  17         SNZ             GO TO DN70 (21)
  18         JMP     DN70
  19 DN69    LDA     K10
  20         STA     TC      TC = .
  21 DN70    CRA
  22         STA     F6      F6 = SXF = 0
  23         STA     SXF
  24         LDA     IM      (A) = IM
  25         JMP*    DN00    RETURN
  26 DN72    LDA     F1      IF F1 = 0, GO TO DN74
  27         SNZ
  28         JMP     DN74
  29         LDA     F1      ELSE, TC = F1
  30         STA     TC
  31         JMP     DN58    GO TO DN58 (14)
  32 DN74    LDA     TC      IF TC = -, GO TO DN82
  33         SUB     K12
  34         SNZ
  35         JMP     DN82
  36         ADD     K102    CHECK FOR TC = +
  37         SNZ
  38         JMP     DN82
  39         LDA     DFL     IF DFL = NON-ZERO
  40         SZE
  41         JMP     DN63    GO TO DN63 (15)
  42         LDA     TC
  43         CAS     K43
  44         JMP     *+3
  45         JMP     DN78
  46         JMP     DN80
  47         CAS     K62
  48         JMP     DN80
  49         NOP
  50 DN78    LDA     K101    IM < INT
  51         STA     IM
  52 DN80    LDA     TC      PACK TC TO ID
  53         JST     PACK
  54         JST     CH00    INPUT CHAR
  55         LDA     DFL     IF DFL IS NOT ZERO,
  56         SZE             GO TO DN67 (18)
  57         JMP     DN67
  58         LDA     NTID    IF NTID = 6, GO TO DN67
  59         SUB     K106
  60         SZE
  61         JMP     DN80
  62         JMP     DN67
  63 DN82    JST     FN00
  64         STA     F1      F1 = CONVERTED TC
  65         JMP     DN06    GO TO DN06 (2)
  66 DN84    LDA     F1      IF F1 = -,
  67         SUB     K102    GO TO DN85(13)
  68         SZE
  69         JMP     DN85
  70         CRA
  71         SUB     TID     COMPLEMENT THREE WORDS AT TID
  72         SZE
  73         JMP     DN8A
  74         SUB     TID+1
  75         SZE
  76         JMP     DN8B
  77         JMP     DN8C
  78 DN8A    STA     TID
  79         LDA     K123
  80         SUB     TID+1
  81 DN8B    STA     TID+1
  82         LDA     K123
  83 DN8C    SUB     TID+2
  84         STA     TID+2
  85 DN85    LDA     SXF     IF SXF = 0, GO T0 DN67 (18)
  86         SNZ
  87         JMP     DN67    ELSE,
  88         LDA     IM      IF IM NOT = REA,
  89         SUB     K102
  90         SZE             GO TO DN67 (18)
  91         JMP     DN67
  92         LDA     F6      ELSE,
  93         SNZ             IF F6 = 0, GO TO DN87
  94         JMP     DN87
  95         LDA     K105
  96         STA     IM      IM = CPX
  97         LDA     TID     INTERCHANGE
  98         IMA     TIDB    3 CELLS
  99         STA     TID     TID
 100         LDA     TID+1   WITH
 101         IMA     TIDB+1  3 CELLS
 102         STA     TID+1   OF
 103         LDA     TID+2   TIDB
 104         IMA     TIDB+2
 105         STA     TID+2
 106         JST     IP00    )-INPUT OPERATOR
 107         JMP     DN70    GO TO DN70 (21)
 108 DN87    LDA     TC      IF TC = ,
 109         SUB     K5
 110         SZE
 111         JMP     DN67    TID-BAR = TID
 112         LDA     TID     F6 = 1
 113         STA     TIDB    GO TO DN01 (1)
 114         LDA     TID+1
 115         STA     TIDB+1  ELSE, GO TO DN67 (18)
 116         LDA     TID+2
 117         STA     TIDB+2
 118         LDA     K101
 119         STA     F6
 120         JMP     DN01
 121 DN90    LDA     F2      IF F2= 0, GO TO DN9A (10)
 122         SNZ
 123         JMP     DN9A
 124         LDA     F3      F3 = - F3
 125         TCA
 126         STA     F3
 127 DN9A    LDA     F3      F4 = F3 - F4
 128         SUB     F4
 129         STA     F4
 130         LDA     K12     F2 = EXP, BIAS + MANTISSA
 131         STA     F2
 132         LDA     TID     IF TID = 0,
 133         ADD     TID+1
 134         ADD     TID+2   GO TO DN85(13)
 135         SNZ
 136         JMP     DN85
 137 DN9C    LDA     TID+2
 138         LGL     1       NORMALIZE ID
 139         SPL
 140         JMP     DN9D    ID IS NORMALIZED
 141         JST     SFT
 142         DAC     ID
 143 *                            F2 = F2 - = SHIFTS
 144         LDA     F2
 145         SUB     K101
 146         STA     F2
 147         JMP     DN9C    CONTINUE NORMALIZE LOOP
 148 DN9D    LDA     F4
 149         CAS     ZERO
 150         JMP     DN9E
 151         JMP     DN9G    FINISHED E FACTOR LOOP
 152         IRS     F4
 153         NOP             F4 = F4 +1
 154         LDA     K155    DIVIDE LOOP COUNTER
 155         STA     TIDN
 156         JST     SRT
 157         DAC     TID
 158         JST     SRT
 159         DAC     TID
 160 DND1    JST     SFT
 161         DAC     TID
 162         LDA     TID+2
 163         SUB     K156    10 AT B=4
 164         SMI
 165         STA     TID+2
 166         SMI
 167         IRS     TID
 168         IRS     TIDN
 169         JMP     DND1    REDUCE DIVIDE COUNTER
 170         JST     SFT
 171         DAC     TID
 172         LDA     TID+2
 173         ANA     K157
 174         STA     TID+2
 175         JMP     DN9C
 176 DN9E    SUB     K101
 177         STA     F4      F4 = F4-1
 178         LDA     F2      F2 = F2+4
 179         ADD     K104
 180         STA     F2
 181         JST     SRT
 182         DAC     ID
 183         JST     MOV3
 184         JST     SRT     ID = ID*10
 185         DAC     ID
 186         JST     SRT
 187         DAC     ID
 188         JST     AD3     ADD THREE WORD INTEGERS
 189         JMP     DN9C
 190 *          CONVERT THREE WORD INTEGER TO INTERNAL FORMAT
 191 DN9G    LDA     TID+2
 192         IAB
 193         LDA     F2
 194         LRS     8
 195         SNZ
 196         JMP     *+3
 197         JST     ER00
 198         BCI     1,CE    CONSTANT'S EXPONENT OVER 8 BITS (OVERFLOW)
 199         IAB
 200         IMA     TID+2
 201         IAB
 202         LDA     TID+1
 203         LGL     1
 204         LRR     8
 205         STA     TID+1
 206         LRR     9
 207         LDA     TID     PACK UP TRIPLE PRECISION
 208         LGL     1
 209         LRR     7       REAL CONSTANT
 210         STA     TID
 211         LDA     F2
 212         LGR     8
 213         SZE
 214         JMP     DN69    GO TO DN69 (20)
 215         JMP     DN84    ELSE. GO TO DN84 (12)
 216 DN9H    STA     IM
 217         LDA     SPF
 218         SUB     K102
 219         SZE
 220         LDA     K106
 221         SUB     K124
 222         ADD     TID
 223         SMI
 224         JMP     DN70
 225         LDA     TID
 226         STA     HOLF    HOLF=NO.OF HOLLERITH CHARS,
 227         STA     F3
 228         TCA
 229         SNZ
 230         JMP     DN9K    FIELD WIDTH OF ZERO
 231         STA     F2      F2= -1(1 CHAR)  OR  -2(2 CHAR)
 232         JST     BLNK    SET ID,ID+1(ID+2 TO ZERO
 233         DAC     TID
 234 DN9J    JST     IC00    INPUT COLUMN (INCLUDING BLANKS)
 235         JST     PACK    PACK CHARACTERS 2 PER WORD
 236         IRS     F2      REDUCE CHARACTER COUNT
 237         JMP     DN9J    INPUT AND PACK MORE CHARACTERS
 238         LDA     F3      F3= 0 IF 2 CHAR. HAVE BEEN INPUT
 239         ANA     K101
 240         SNZ
 241         JMP     *+3
 242         LDA     K8      ='240  (SP)
 243         JST     PACK    SHIFT A SPACE INTO THE LAST WORD
 244         IRS     IM
 245 DN9M    JST     CH00    INPUT THE TERMINATING CHARACTER
 246         JMP     DN67    FINISH OPERATOR AND EXIT
 247 DN9K    JST     ER00
 248         BCI     1,HF
 249 DN9N    LDA     K105    SET .NOT. OPERATOR (TC=5)
 250         STA     TC      SET .NOT. OPERATOR (TC=5)
 251         CRA
 252         STA     IM      IM=0 = UNDEFINED
 253         JMP     DN68
 254 DNX1    BSS     3
 255 DNX2    DAC     **      OVERFLOW FLAG
 256         JMP*    *-1
 257 *
 258 *
 259 *             ************
 260 *             *INPUT ITEM*
 261 *             ************
 262 *          INPUTS AND ASSIGNS ITEM (IF ONE EXISTS)
 263 *
 264 II00    DAC     **
 265         JST     DN00    INPUT DNA
 266         SNZ             IF (A) = 0
 267         JMP*    II00    RETURN
 268         JST     AS00    NO, ASSIGN ITEM
 269         LDA     IM
 270         JMP*    II00    RETURN (A) = IM
 271 *
 272 *
 273 *             ***************
 274 *             *INPUT OPERAND*
 275 *             ***************
 276 *          EXIT WITH ITEM MODE IN A (TC SET TO . IF NO
 277 *               OPERAND)
 278 *
 279 OP00    DAC     **      INPUT OPERAND
 280         JST     II00     INPUT ITEM
 281         SZE             IF IM = 0, SKIP
 282         JMP*    OP00    ELSE (A) = IM, RETURN
 283         LDA     K10     TC = .
 284         STA     TC      (A) = 0
 285         CRA
 286         JMP*    OP00    RETURN
 287 *
 288 *
 289 *             ************
 290 *             *INPUT NAME*
 291 *             ************
 292 *          INPUT OPERAND AND ENSURE THAT IT IS A NAME
 293 *
 294 NA00    DAC     **       INPUT NAME
 295         JST     OP00    INPUT OPERAND
 296         LDA     NT      IF NT = 1,
 297         SNZ
 298         JMP     NA10
 299         JST     ER00
 300         PZE     9
 301 NA10    LDA     IM      (A) = IM
 302         JMP*    NA00    RETURN
 303 *
 304 *
 305 *             ***************
 306 *             *INPUT INTEGER*
 307 *             ***************
 308 *          INPUT ITEM AND ENSURE THAT IT IS AN INTEGER CONSTANT
 309 *               GREATER THAN ZERO
 310 *
 311 IG00    DAC     **      INPUT INTEGER
 312         JST     DN00    INPUT - DNA
 313         LDA     F1
 314         SZE             IF F1 = 0,
 315         JMP     IG20    AND NT = 1,
 316         LDA     NT      AND IM = INT,
 317         SNZ             AND TID L2**15,
 318         JMP     IG20    GO TO IG10
 319         LDA     IM      LSE, GO TO IG20
 320         SUB     K101
 321         SZE
 322         JMP     IG20
 323         LDA     TID+1
 324         SZE
 325         JMP     IG20
 326         LDA     TID+2
 327         SZE
 328         JMP     IG20
 329 IG10    LDA     TID
 330         JMP*    IG00
 331 IG20    JST     ER00    ERROR
 332         BCI     1,IN    INTEGER REQUIRED
 333 *
 334 *
 335 *             ***********************
 336 *             *INPUT INTEGER VAR/CON*
 337 *             ***********************
 338 *
 339 IV00    DAC     **
 340         JST     OP00    INPUT OPERAND
 341         JST     IT00    INTER TEST
 342         JST     TV00    TAG VARIABLE
 343         JMP*    IV00    EXIT
 344 *
 345 *
 346 *             ************************
 347 *             *INPUT INTEGER VARIABLE*
 348 *             ************************
 349 *
 350 IR00    DAC     **      INPUT INT VAR
 351         JST     IV00    INPUT INT VAR/CON
 352         JST     NC00    NON-CONSTANT TEST
 353         JMP*    IR00    RETURN
 354 *
 355 *
 356 *             ************************
 357 *             *INPUT STATEMENT NUMBER*
 358 *             ************************
 359 *          NUMBER IS FORMED AS SPECIAL NAME , NOT CONVERTED
 360 *               TO NUMERIC
 361 *
 362 IS00    DAC     **
 363 IS04    CRA
 364         STA     NT
 365         STA     IM
 366         STA     IU      IU = IM = IT = 0
 367         STA     NTID    PUT LEADING 'S' IN STATEMENT NO,
 368         LDA     K79
 369         JST     PACK
 370 IS10    JST     ID00    INPUT DIGIT
 371         SZE
 372         JMP     IS20    NOT A DIGIT GO TO IS20
 373         LDA     NTID
 374         SUB     K106
 375         SMI
 376         JMP     IS22
 377         LDA     TC
 378         JST     PACK    PACK TC TO ID - LEGAL ST, NO, CHAR
 379         LDA     TID
 380         CAS     K79X
 381         JMP     IS10
 382         JMP     IS04    IGNORE LEAD ZERO ON ST. NO,
 383         JMP     IS10
 384 IS20    LDA     NTID
 385         SUB     K101
 386         SMI
 387         JMP     IS25
 388 IS22    JST     ER00
 389         BCI     1,ST    ILLEGAL STATEMENT NUMBER FORMAT
 390 IS25    JST     AS00    ASSIGN ITEM
 391         JST     STXA
 392         LDA     DP+1,1
 393         ANA     K111
 394         STA     DP+1,1  IU = 0
 395         LDA     AF      ADDRESS FIELD IS
 396         CAS     XST     LE XST - ALREADY ASSIGNED
 397         JMP*    IS00
 398         JMP*    IS00    OK - OTHERWISE
 399         LDA     AT      MUST HAVE STR-ABS OTHERWISE
 400         CAS     K102
 401         JMP     *+2
 402         JMP*    IS00    !!!
 403         JST     ER00
 404         BCI     1,RN    REFERENCE TO A SPECIFICATION STMNT NUMBER
 405 K79     OCT     337
 406 K79X    OCT     157660
 407 *
 408 SY00    DAC     **      INPUT SYMBOL
 409         LDA     K101
 410         STA     NTF     NTF NOT 0 - DON'T SET IU IN AS00
 411         JST     NA00    INPUT NAME
 412         JMP*    SY00    EXIT
 413 *
 414 *             ************************
 415 *             *EXAMINE NEXT CHARACTER*
 416 *             ************************
 417 *          CHECK NEXT CHAR FOR DIGIT (BACKUP ONE COL, THEN EXIT)
 418 *
 419 XN00    DAC     **
 420         JST     ID00    INPUT DIGIT
 421         JST     UC00    UNINPUT COLUMM
 422         JMP*    XN00
 423 K1      BCI     3,TRUE.
 424 K2      BCI     3,FALSE.
 425 K3      OCT     247
 426 KNOT    BCI     3,NOT.  CONSTANT FOR .NOT. TEST
 427 K11     OCT     304     0D
 428 K14     OCT     310     0H
 429 K62     OCT     316     0N
 430 K64     OCT     336     0)
 431 *
 432 *
 433 *             ********************
 434 *             *ALL CHARACTER TEST*
 435 *             ********************
 436 *
 437 TS00    DAC     **      TEST (A) AGAINST TC
 438         SUB     TC
 439         SNZ
 440         JMP*    TS00    RETURN
 441         JST     ER00    TO ERROR TEST
 442         BCI     1,CH    IMPROPER TERMINATING CHARACTER
 443 *
 444 *
 445 *             *******************
 446 *             *)- INPUT OPERATOR*
 447 *             *******************
 448 *
 449 IP00    DAC     **
 450         LDA     K4      TEST - )
 451         JST     TS00
 452         JST     CH00    INPUT CHAR
 453         JST     FN00    FINISH OPERATOR
 454         LDA     B       B = B-16
 455         SUB     K109
 456         STA     B
 457         CRA             (A) = 0
 458         JMP*    IP00    RETURN
 459 *
 460 *
 461 *
 462 *          B1                COMMA OR C/R TST
 463 B1      LDA     K134    IF TC = ','(CONVERTED TO 17)
 464         SUB     TC
 465         SNZ
 466         JMP*    A9T2    GO TO SIDSW
 467         JMP     A1      ELSE, GO TO C/R TEST
 468 *
 469 *
 470 NR00    DAC     **      NON-REL TEST
 471         LDA     AT
 472         SUB     K101    IF AT = 1 GO TO ERROR-
 473         SZE             TEST
 474         JMP*    NR00    RETURN
 475         JST     ER00    ERROR TEST ROUTINE
 476         BCI     1,MS    MULTIPLY DEFINED STATEMENT NUMBER
 477 *
 478 *
 479 *             ***************
 480 *             *NO USAGE TEST*
 481 *             ***************
 482 *
 483 NU00    DAC     **      N0 USAGE TEST
 484         LDA     IU
 485         SNZ             IF IU NOT = 0, TO ERROR
 486         JMP*    NU00    RETURN
 487         JST     ER00    ERROR TEST
 488         BCI     1,NU    NAME ALREADY BEING USED
 489 *
 490 *
 491 *             *******************
 492 *             *NON-CONSTANT TEST*
 493 *             *******************
 494 *
 495 NC00    DAC     **      NON CONSTANT TEST
 496         LDA     NT
 497         SNZ             IF NT NOT = 0, TO ERROR TEST
 498         JMP*    NC00    RETURN
 499         JST     ER00    ERROR TEST
 500         BCI     1,NC    CONSTANT MUST BE PRESENT
 501 *
 502 *
 503 *             *********************
 504 *             *NON SUBPROGRAM TEST*
 505 *             *********************
 506 *
 507 NS00    DAC     **      NON SUBPROGRAM TEST
 508         LDA     IU
 509         SUB     K101    IF IU = 1, GO TO-
 510         SZE             ERROR TEST
 511         JMP*    NS00    RETURN
 512         JST     ER00    ERROR TEST
 513         BCI     1,NS    SUBPROGRAM NAME NOT ALLOWED
 514 *
 515 *
 516 *             **********
 517 *             *ARR TEST*
 518 *             **********
 519 *
 520 AT00    DAC     **      ARRAY TEST
 521         LDA     IU
 522         SUB     K103    IF IU = 3, GO TO
 523         SNZ
 524         JMP*    AT00    RETURN
 525         JST     ER00    ERROR TEST
 526         BCI     1,AR    ITEM NOT AN ARRAY NAME
 527 *
 528 *
 529 *             **************
 530 *             *INTEGER TEST*
 531 *             **************
 532 *
 533 IT00    DAC     **      INTEGER TEST
 534         LDA     IM
 535         SUB     K101    IF IM = 1, GO TO-
 536         SNZ             ERROR ROUTINE, ELSE
 537         JMP*    IT00    RETURN
 538         JST     ER00    TO ERROR TEST
 539         BCI     1,IT    ITEM NOT AN INTEGER
 540 *
 541 *
 542 TA00    DAC     **
 543         LDA     AT      STRING-ABS TEST
 544         SUB     K102
 545         SNZ
 546         JMP*    TA00
 547         JST     ER00
 548         BCI     1,NR    ITEM NOT A RELATIVE VARIABLE
 549 *
 550 *
 551 *
 552 *
 553 *
 554 *
 555 *
 556 *
 557 AD3     DAC     **      ADD TWO THREE WORD INTEGERS,
 558         LDA     TID
 559         ADD     DNX1
 560         CSA
 561         STA     TID
 562         LDA     TID+1
 563         ACA
 564         ADD     DNX1+1
 565         CSA
 566         STA     TID+1
 567         LDA     TID+2
 568         ACA
 569         ADD     DNX1+2
 570         STA     TID+2
 571         JMP*    AD3
 572 *
 573 *
 574 *             ***********************
 575 *             *ASSIGN INDEX REGISTER*
 576 *             ***********************
 577 *
 578 STXA    DAC     **
 579         LDA     A
 580         STA     0
 581         JMP*    STXA
 582 STXI    DAC     **
 583         LDA     I
 584         STA     0
 585         JMP*    STXI
 586 K153    OCT     16
 587 IM00    DAC     **
 588         STA     T1IM    MULTIPLY A BY B
 589         LDA     K120    =-15
 590         STA     T2IM
 591         CRA
 592         RCB             C BIT = 0
 593 IM10    LRL     1       LOW BIT OF B INTO C
 594         SRC             SKIP IF B = 0
 595         ADD     T1IM
 596         IRS     T2IM
 597         JMP     IM10
 598         LLL     14
 599         JMP*    IM00    RETURN, RESULT IN A
 600 T1IM    PZE     0
 601 T2IM    PZE     0
 602 *
 603 *
 604 NF00    DAC     **      CONSTRUCT EXTERNAL NAME
 605         LDA     K80     ENTRY FOR FORTRAN GENERATER
 606         STA     NAMF
 607         LDA     K81     SUBROUTINE CALLS,
 608         STA     NAMF+2
 609         JMP*    NF00
 610 K80     BCI     1,F$
 611 K81     BCI     1,
 612 KM92    DEC     1       001 = INT
 613         DEC     2       010 = REA
 614         DEC     1       011 = LOG
 615         DEC     0       - -
 616         DEC     4       101 = CPX
 617         DEC     3       110 = DSL
 618         OCT     3       111 = HOL
 619 *
 620 *
 621 BLNK    DAC     **      CLEAR A 3/36
 622         JST     SAV     AREA TO ZEROS
 623         LDA*    BLNK
 624         STA     XR
 625         CRA             CLEAR 3 WORDS OF MEMORY
 626         STA     1,1     PARAMETER INPUT ADDRESS TO 0
 627         STA     2,1
 628         STA     0,1
 629         JST     RST
 630         IRS     BLNK
 631         JMP*    BLNK    EXIT
 632 *
 633 *
 634 MOV3    DAC     **      MOVE 3-WORDS
 635         LDA     TID     TO TEMO STORE
 636         STA     DNX1
 637         LDA     TID+1
 638         STA     DNX1+1
 639         LDA     TID+2
 640         STA     DNX1+2
 641         JMP*    MOV3
 642 *
 643 *
 644 *
 645 *
 646 CIB     DAC     **      COMPARE IBUF TO A CONSTANT
 647         JST     SAV     SAVE INDEX
 648         LDA*    CIB     +DDR OF CON+3,0
 649         STA     CIBZ
 650         CRA
 651         SUB     K103    XR=-3
 652         STA     XR
 653 CIBB    LDA     IBUF+3,1
 654         SUB*    CIBZ
 655         SZE
 656         JMP     CIBD
 657         IRS     XR
 658         JMP     CIBB
 659 CIBC    IRS     CIB
 660         JST     RST     RESTORE INDEX
 661         JMP*    CIB
 662 CIBD    IRS     CIB
 663         JMP     CIBC
 664 CIBZ    DAC     **
 665 *
 666 *
 667 *
 668 *
 669 SAV     DAC     **      SAVE INDEX REGISTER
 670         STA     SAVY    STACKED IN PUSH DOWN LIST
 671         LDA     XR
 672         STA*    SAV9
 673         IRS     SAV9
 674         LDA     SAVY
 675         JMP*    SAV
 676 RST     DAC     **      RESTORE INDEX REGISTER
 677         STA     SAVY
 678         LDA     SAV9    UNSTACK PUSH DOWN LIST
 679         SUB     K101
 680         STA     SAV9
 681         LDA*    SAV9
 682         STA     XR
 683         LDA     SAVY
 684         JMP*    RST
 685 SAVY    PZE     0
 686 SAV9    DAC     SAVX    IS INITIATED BY A092
 687 SAVX    BSS     20
 688 *
 689 *
 690 PACK    DAC     **      PLACE CHARACTER IN A
 691         STA     PAK7
 692         LDA     NTID    INTO ID - UPDATE 3 WORDS OF
 693 PAK1    SNZ
 694         JMP     PAK4    ID
 695         LRL     1
 696         ADD     PAK9
 697         STA     PAK8
 698         LDA     PAK7
 699         IAB
 700         SPL
 701         JMP     PAK3
 702         LLL     24
 703         ADD     K8
 704 PAK2    STA*    PAK8
 705         IRS     NTID
 706         JMP*    PACK
 707 PAK3    LLL     8
 708         LDA*    PAK8
 709         LGR     8
 710         LLL     8
 711         JMP     PAK2
 712 PAK4    LDA     PAK6
 713         STA     TID
 714         STA     TID+1
 715         STA     TID+2
 716         STA     TID+3
 717         LDA     NTID
 718         JMP     PAK1+2
 719 PAK6    BCI     1,
 720 PAK7    DAC     **
 721 PAK8    DAC     **
 722 PAK9    DAC     TID
 723 *
 724 *
 725 *             ***************
 726 *             *ERROR ROUTINE*
 727 *             ***************
 728 *
 729 ER00    DAC     **      ERROR ROUTINE
 730         LDA     SAV9
 731         STA     SAVX
 732         LDA     ER93    =-35
 733         STA     0       SET INDEX
 734         LDA     ER91    (*)(*)
 735         STA     PRI+35,1        SET ** INTO PRINT BUFFER
 736         IRS     0       SET COMPLETE PRINT BUFFER TO ********
 737         JMP     *-2
 738         LDA     CC
 739         ARS     1       CC = CC/2
 740         SUB     K101    =1
 741         SPL
 742         CRA
 743         STA     XR
 744         LDA     EBAR    (NEGATIVE IF NOT WITHIN AN EQUIVALENCE ST.)
 745         SPL             SKIP IF PROCESSING AN EQUIVALENCE STATEMENT
 746         JMP     *+3
 747         LDA     KAEQ    ='142721  (=(E)(Q)  )
 748         STA     PRI+1,1
 749         LDA*    ER00
 750         STA     PRI,1   SET ERROR TYPE LETTERS INTO THE BUFFER
 751         CALL    F4$SYM  PRINT THE BUFFER
 752         DAC     PRI
 753         JST     PRSP    SET PRINT BUFFER TO SPACES
 754         LDA     TC
 755 ER20    CAS     CRET    INPUT CHARACTERS UNTIL C/R
 756         JMP     *+2
 757         JMP     C7      GO TO STATEMENT INPUT
 758         JST     CH00
 759         JMP     ER20
 760 ER91    BCI     1,**
 761 ER93    OCT     177735  -35
 762 *
 763 *
 764 SRT     DAC     **
 765         JST     SAV
 766         LDA*    SRT     SHIFT RIGHT ONE PLACE
 767         STA     XR                                  TRIPLE PRECISION
 768         LDA     0,1
 769         IAB
 770         LDA     1,1
 771         LRS     1
 772         LGL     1
 773         IAB
 774         STA     0,1
 775         LDA     2,1
 776         LRS     1
 777         STA     2,1
 778         IAB
 779         STA     1,1
 780         JST     RST
 781         IRS     SRT
 782         JMP*    SRT
 783 *
 784 *
 785 SFT     DAC     **      TRIPLE PRECISION
 786         JST     SAV     SHIFT LEFT ONE PLACE
 787         LDA*    SFT
 788         STA     XR
 789         LDA     0,1
 790         IAB
 791         LDA     1,1
 792         LLS     1
 793         CSA
 794         STA     1,1
 795         IAB
 796         STA     0,1
 797         ACA
 798         LRS     1
 799         LDA     2,1
 800         LLS     1
 801         CSA
 802         STA     2,1
 803         JST     RST
 804         IRS     SFT
 805         JMP*    SFT
 806 *
 807 LIST    DAC     **
 808         JST     PRSP
 809         SR2
 810         JMP     *+3
 811         CALL    F4$SYM  PRINT BLANK LINE
 812         DAC     PRI
 813         CALL    F4$SYM  PRINT SOURCE INPUT LINE
 814         DAC     CI
 815         JMP*    LIST
 816 *             *************
 817 *             *ASSIGN ITEM*
 818 *             *************
 819 *          CHECKS ASSIGNMENT AREA OF DATA POOL (A0 TO ABAR)
 820 *               FOR ITEM DEFINED BY ID, IM, IU, ETC.
 821 *                    IF FOUND, EXIT WITH POINTER AND
 822 *                        ASSIGNMENTS DATA SET, OTHERWISE
 823 *                    ASSIGN THE ITEM.
 824 *
 825 *
 826 *
 827 T0AS    PZE     0
 828 AS00    DAC     **
 829         CRA
 830         STA     A       A = A (0)
 831 AS04    JST     STXA
 832         JST     NXT     GET NEXT ENTRY
 833         JMP     AS30    AT END, GO TO AS30
 834         LDA     NT
 835         SUB     NTA     NT = NT(A)
 836         SZE
 837         JMP     AS04    NO, G0 TO AS04
 838         LDA     TID
 839         SUB     TIDA
 840         SZE
 841         JMP     AS04    TID = TID(A)
 842         LDA     TID+1
 843         SUB     TIDA+1
 844         SZE
 845         JMP     AS04    NO, GO TO AS04
 846         LDA     TID+2
 847         SUB     TIDA+2
 848         SZE
 849         JMP     AS04
 850         LDA     NT      IF NT (A) .NE. 0,
 851         SNZ             GO TO AS10
 852         JMP     AS16    GO TO AS16 (4)
 853 AS10    LDA     IM      IF IM .NE. IM (A),
 854         SUB     IMA     GO TO AS04 (1)
 855         SZE
 856         JMP     AS04
 857         LDA     IU      IF IU = 0,
 858         SNZ             OR NOT EQUAL IU (A)
 859         JMP     AS04            GO T0 AS04 (1)
 860         SUB     IUA
 861         SZE
 862         JMP     AS04    ELSE,
 863         LDA     IM
 864         SUB     K105    GO TO AS16 (4)
 865         SZE
 866         JMP     AS16
 867         JST     NXT     ELSE, GET NEXT ENTRY
 868         JMP     AS30
 869         LDA     TIDA    IF IU (A) = TIDB
 870         SUB     TIDB    GO TO AS16 (4)
 871         SZE             ELSE, GO TO AS04 (1)
 872         JMP     AS04
 873         LDA     TIDA+1
 874         SUB     TIDB+1
 875         SZE
 876         JMP     AS04
 877         LDA     TIDA+2
 878         SUB     TIDB+2
 879         SZE
 880         JMP     AS04
 881         LDA     A
 882         SUB     K105
 883         STA     A
 884 AS16    LDA     IUA     IF IU (A) .NE. 0
 885         ADD     NTF
 886         SZE
 887         JMP     AS18    GO TO AS18 (5)
 888         LDA     SPF     IF SPF = 0, GO TO AS18 (5)
 889         SNZ
 890         JMP     AS18
 891         LDA     TC      IF TC = (
 892         SUB     K17
 893         SZE
 894         JMP     AS19
 895         JST     TG00    TAG SUBPROGRAM
 896 AS18    CRA             SET NTF TO 0
 897         STA     NTF     SET NTF TO 0
 898         JST     FA00    GO TO FETCH ASSIGNS
 899         JST     STXA
 900         LDA     IM
 901         JMP*    AS00    RETURN
 902 AS19    JST     TV00    TAG VARIABLE
 903         JMP     AS18
 904 AS30    JST     BUD     BUILD ASSIGNMENT ENTRY
 905         LDA     NT      IF NT = 1
 906         SZE
 907         JMP     AS32    OR IV = VAR,
 908         LDA     IU
 909         SUB     K102
 910         SZE
 911         JMP     AS40    AMD
 912 AS32    LDA     IM      IF IM = CPX,
 913         SUB     K105
 914         SZE
 915         JMP     AS40
 916         STA     IU      MOVE 1ST PART OF
 917         LDA     TIDB    COMPLEX ENTRY TO
 918         STA     TID     TID AND BUILD
 919         LDA     TIDB+1  ASSIGNMENT ENTRY
 920         STA     TID+1
 921         LDA     TIDB+2
 922         STA     TID+2
 923         LDA     A
 924         ADD     K105
 925         STA     A
 926         JST     BUD
 927         LDA     A
 928         SUB     K105    RESTORE A
 929         STA     A
 930 AS40    LDA     ABAR
 931         SUB     A       TO = -(ABAR-A+5)
 932         ADD     K105    GIVING NO. OF WORDS TO MOVE TABLES UP
 933         TCA
 934         STA     T0AS
 935         TCA
 936         ADD     DO      CO=DO+TO
 937         STA     DO
 938         LDA     IFLG    IF IFLG = 0, THERE IS NO EXPRESSION TABLE
 939         SNZ
 940         JMP     AS60    GO TO AS60
 941         LDA     I
 942         SUB     T0AS
 943         STA     I       I = I - T0(T0 IS NEGATIVE)
 944         AOA
 945 AS41    CAS     L       CHECK AGAINST BOTTOM OF TRIAD TABLE
 946         NOP
 947         JMP     AS50
 948         ADD     '104    =DP,1
 949         STA     AS91    AS91 = NEW TABLE TOP
 950         ADD     T0AS
 951         STA     AS92    AS92
 952         SUB     T0AS    COMPUTE SIZE OF FLOATING TABLES
 953         SUB     '104    =DP,1
 954         SUB     DO
 955         SNZ             IF ZERO, ASSIGN TABLE ONLY,
 956         JMP     AS16
 957         TCA
 958         STA     T0AS
 959         CRA
 960         STA     XR
 961 AS46    LDA*    AS92    END-5
 962         STA*    AS91    END  (MOVE TABLES UP)
 963         LDA     0
 964         SUB     K101    =1
 965         STA     0       REDUCE INDEX
 966         IRS     T0AS    = NO, OF WORDS TO MOVE
 967         JMP     AS46
 968         JMP     AS16
 969 AS50    JST     ER00
 970         BCI     1,MO    DATA POOL OVERFLOW
 971 AS60    LDA     DO
 972         ADD     D
 973         JMP     AS41
 974 AS91    DAC     0
 975 AS92    DAC     **
 976 *
 977 *
 978 *
 979 *
 980 *             ****************
 981 *             *TAG SUBPROGRAM*
 982 *             ****************
 983 *          TAG ITEM AS A SUBPROGRAM, CHECK TO SEE IF
 984 *               NAME IS IN IMPLICIT MODE TABLE AND SET
 985 *               MODE ACCORDINGLY
 986 *
 987 TG00    DAC     **
 988         LDA     IU
 989         SUB     K101    IF IU = SUB
 990         SNZ
 991         JMP*    TG00    RETURN, ELSE
 992         JST     NU00    NO * USAGE TEST
 993         LDA     TG22    =-21
 994         STA     0       SET INDEX
 995 TG04    LDA     ID+1    CHARACTERS 3 AND 4
 996         CAS     TGT2+21,1       IMPLICIT MODE SUBR. NAME TABLE
 997         JMP     *+2
 998         JMP     TG10
 999 TG06    IRS     0
1000         JMP     TG04    NOT DONE WITH TABLE
1001 TG08    LDA     K101    =1  (IU=SUBR.)
1002         STA     IU
1003         JST     STXA
1004         LDA     DP+1,1  IU(A) = SUB
1005         LGL     1
1006         SSM
1007         LGR     1
1008         STA     DP+1,1
1009         JMP*    TG00    RETURN
1010 *
1011 TG10    LDA     ID      CHARACTERS 1 AND 2
1012         ANA     K111    ='37777
1013         ADD     HBIT    ='140000
1014         SUB     TGT1+21,1
1015         SZE
1016         JMP     TG06    CONTINUE SEARCH
1017         LDA     ID+2    CHARACTERS 5 AND 6
1018         SUB     TGT3+21,1
1019         SZE
1020         JMP     TG06    CONTINUE SEARCH
1021         LDA     TGT1+21,1
1022         LGR     8
1023         ANA     K107    =7   (=3 IF CPX, 4 IF DBL)
1024         ADD     K102    =2    (=5 IF CPX, 6 IF DBL)
1025         JST     DM00    DEFINE IM
1026         JMP     TG08
1027 *
1028 TG22    OCT     177753  =-21
1029 *
1030 *...........IMPLICIT MODE SUBROUTINE NAME TABLE
1031 TGT1    BCI     6,DECEDLCLDLDS
1032         BCI     6,CSDCCCDSCSDA
1033         BCI     6,DADMDADMDMDS
1034         BCI     3,DBCMCO
1035 TGT2    BCI     6,XPXPOGOGOGIN
1036         BCI     6,INOSOSQRQRTA
1037         BCI     6,TAODBSAXINIG
1038         BCI     3,LEPLNJ
1039 TGT3    BCI     6,        10    /
1040         BCI     6,      T T N   /
1041         BCI     6,N2    1 1 N   /
1042         BCI     3,  X G         /
1043 *
1044 *
1045 TIDA    BSS     3
1046 TIDB    BSS     3
1047 *
1048 *  -       TV00  TAG VARIABLE
1049 TV00    DAC     **
1050         LDA     IU      IF IU = 'VAR',
1051         SUB     K102
1052         SNZ
1053         JMP*    TV00    RETURN
1054         JST     NU00    ELSE, NO USAGE TEST
1055         JST     STXA
1056         LDA     DP+1,1
1057         ANA     K111    IU (A) = 'VAR'
1058         SSM
1059         STA     DP+1,1
1060         JMP*    TV00    RETURN
1061 *
1062 *
1063 *
1064 *
1065 *
1066 *             **************
1067 *             *FETCH ASSIGN*
1068 *             **************
1069 *          SET ASSIGNMENT DATA FROM ASSIGN (EXCEPT ID)
1070 *               EXPAND DIMENSION INFO IF ARRAY
1071 *
1072 FA00    DAC     **
1073         JST     STXA
1074         LDA     DP,1
1075         LRL     15
1076         STA     NT      NT=NT(A)
1077         CRA
1078         LLL     3
1079         STA     AT      AT=AT(A)
1080         CRA
1081         LLL     3       IM = IM(A)
1082         STA     IM
1083         STA     0
1084         LDA     KM92-1,1
1085         STA     D0      D0 = NUMBER OF WORDS
1086         ALS     2
1087         ADD     D0
1088         STA     X       X = POINTER TO CONSTANT NUMBER OF WORDS
1089         JST     STXA
1090         LDA     DP+1,1
1091         LRL     14
1092         STA     IU
1093         SUB     K103    IF IU NOT 'ARR'
1094         SNZ
1095         JMP     FA10
1096         CRA
1097         LLL     14      AF = GF(A)
1098         STA     AF
1099         JMP*    FA00
1100 FA10    LLL     14
1101         STA     0       INDEX = GF(A)
1102         LDA     DP+4,1
1103         STA     X1      POINTER OF DIMENSION 1
1104         LDA     DP+3,1
1105         STA     X2      POINTER OF DIMENSION 2
1106         LDA     DP+2,1
1107         STA     X3      POINTER OF DIMENSION 3
1108         LDA     DP+1,1
1109         ANA     K111    ='37777
1110         STA     AF      AF = GF(GF(A))
1111         LDA     DP,1
1112         LGR     9
1113         ANA     K107    =7
1114         STA     ND      NUMBER OF DIMENSIONS
1115         STA     0
1116         LDA     K101    =1
1117         STA     D2
1118         STA     D3
1119         JMP*    FA91-1,1
1120 FA22    LDA     X3      FETCH 3RD DIMENSION SIZE
1121         STA     XR
1122         JST     FA40
1123         STA     D3      STORE D3
1124 FA24    LDA     X2
1125         STA     XR
1126         JST     FA40
1127         STA     D2      D2 = 2ND DIMENSION SIZE
1128 FA26    LDA     X1
1129         STA     XR
1130         JST     FA40
1131         STA     D1      D1 = 1ST DIMENSION SIZE
1132         JST     STXA    EXIT WITH AF IN A
1133         LDA     AF
1134         JMP*    FA00
1135 FA40    DAC     **
1136         LDA     DP,1    IM OF SUBSCRIPT VALUE
1137         SSP
1138         LGR     12
1139         SUB     K105    =5
1140         SZE             SKIP IF DUMMY SUBSCRIPT
1141         LDA     DP+4,1  FETCH VALUE OF SUBSCRIPT
1142         JMP*    FA40
1143 FA91    DAC     FA26
1144         DAC     FA24
1145         DAC     FA22
1146 *
1147 *
1148 *             ************
1149 *             *FETCH LINK*
1150 *             ************
1151 *          EXPAND LINK FIELD AND FETCH ASSIGNS FOR THE
1152 *               LINKED ITEM
1153 *
1154 FL00    DAC     **
1155         JST     STXA
1156         LDA     DP,1    A = 5 * CL(A)
1157         ANA     K118
1158         STA     FLT1
1159         ALS     2
1160         ADD     FLT1    (FLT1 ALSO USED BY ASSIGN SPEC)
1161         STA     A
1162         JST     FA00    FETCH ASSIGN
1163         JST     KT00    D0 = = WDS /ITEM
1164         LDA     A
1165         SUB     F       (A) = A-F
1166         JMP*    FL00    RETURN
1167 *
1168 *
1169 *             *******************
1170 *             *D0=WORDS FOR LINK*
1171 *             *******************
1172 *          D = ITEM MODE SIZE TIMES THE TOTAL SIZE IF
1173 *               THE ITEM IS AN ARRAY
1174 *
1175 KT00    DAC     **
1176         LDA     IU      IF IU NOT 'ARR'
1177         SUB     K103
1178         SZE
1179         JMP*    KT00    RETURN
1180         LDA     D0
1181         IAB             D0 = D0 * D1 * D2 * D3
1182         LDA     D1
1183         JST     IM00    MULTIPLY A BY B
1184         IAB
1185         LDA     D2
1186         JST     IM00    MULTIPLY A BY B
1187         IAB
1188         LDA     D3
1189         JST     IM00    MULTIPLY A BY B
1190         STA     D0
1191         JMP*    KT00    RETURN
1192 *
1193 *
1194 *
1195 *             ***********
1196 *             *DEFINE IM*
1197 *             ***********
1198 *          IM SUBA = IM (SET FROM A REG)
1199 *
1200 DM00    DAC     **
1201         STA     IM      IM = (A)
1202         JST     STXA    ESTABLISH A
1203         LDA     DP,1
1204         LRL     9
1205         LGR     3       IM(A) = IM
1206         LGL     3
1207         ADD     IM
1208         LLL     9
1209         STA     DP,1
1210         JMP*    DM00
1211 *
1212 *
1213 *             ***********
1214 *             *DEFINE AF*
1215 *             ***********
1216 *          AF SUBA = AF (SET FROM A REG)
1217 *
1218 DA00    DAC     **
1219         STA     AF      AF = (A)
1220         LRL     14
1221         JST     STXA
1222 DA10    LDA     DP+1,1  IF IU (A) NOT ARR
1223         LGR     14
1224         CAS     K103    GF (A) : AF
1225         JMP     *+2
1226         JMP     DA20    ELSE, GF (GF (A)) = AF
1227         LLL     14
1228         STA     DP+1,1
1229         JMP*    DA00    RETURN
1230 DA20    LDA     DP+1,1
1231         ANA     K111
1232         STA     GFA
1233         STA     0
1234         JMP     DA10
1235 NXT     DAC     **      GET NEXT ENTRY
1236         LDA     A       FROM ASSIGNMENT
1237         ADD     K105    =5
1238         STA     A
1239         STA     0
1240         CAS     ABAR
1241         JMP*    NXT
1242         NOP
1243         IRS     NXT
1244         LDA     DP,1
1245         LRL     15
1246         STA     NTA     NT(A) = NT FROM (A)
1247         CRA
1248         LLL     3
1249         STA     ATA     AT(A) = AT FROM (A)
1250         CRA
1251         LLL     3
1252         STA     IMA     IM(A) = IM FROM (A)
1253         CRA
1254         LLL     9
1255         STA     CLA     CL(A) = CL FROM (A)
1256         LDA     DP+1,1
1257         LRL     14
1258         STA     IUA     IU(A) = IU FROM (A)
1259         CRA
1260         LLL     14
1261         STA     GFA     GF(A) = GF FROM (A)
1262         LDA     DP+2,1
1263         STA     TIDA+2  TID(A) = TID FROM (A)
1264         LDA     DP+3,1
1265         STA     TIDA+1
1266         LDA     DP+4,1
1267         STA     TIDA
1268         LRL     15
1269         STA     DTA     DT(A) = DT FROM (A)
1270         CRA
1271         LLL     1
1272         STA     TTA     TT(A) = TT FROM (A)
1273         LDA     NTA     NT(A) = NT FROM (A)
1274         SZE
1275         JMP*    NXT
1276         LDA     DP+4,1
1277         SSM
1278         ALR     1
1279         SSM
1280         ARR     1
1281         STA     TIDA
1282         JMP*    NXT
1283 *
1284 *
1285 BUD     DAC     **      BUILD ASSIGNMENT
1286         JST     STXA
1287         STA     ABAR
1288         LDA     TID     TABLE ENTRY
1289         STA     DP+4,1
1290         LDA     TID+1
1291         STA     DP+3,1
1292         LDA     TID+2
1293         STA     DP+2,1
1294         LDA     IU
1295         STA     IUA
1296         LGL     14
1297         STA     DP+1,1
1298         LDA     NT
1299         LGL     3
1300         ADD     K102    AT = STR/+BS
1301         LGL     3
1302         ADD     IM
1303         LRL     16
1304         STA     CL
1305         LDA     K102
1306         STA     AT
1307         LDA     A       CL(A) = A/5
1308         SUB     K105
1309         SPL
1310         JMP     *+3
1311         IRS     CL
1312         JMP     *-4
1313         LLL     25
1314         ADD     CL
1315         STA     DP,1
1316         SPL
1317         JMP*    BUD
1318         LDA     DT
1319         LGL     1
1320         ADD     TT
1321         LGL     14
1322         IMA     DP+4,1
1323         ANA     K111
1324         ADD     DP+4,1
1325         STA     DP+4,1
1326         JMP*    BUD
1327 *
1328 *
1329 *
1330 *
1331 *
1332 *             ************
1333 *             *DEFINE AFT*
1334 *             ************
1335 *          AT SUBA = AT (FROM B REG), THEN DEFINE AF
1336 *
1337 AF00    DAC     **
1338         IAB
1339         STA     AF90
1340         JST     STXA
1341         LDA     AF90
1342         LGL     12
1343         IMA     DP,1
1344         ANA     AF91
1345         ADD     DP,1
1346         STA     DP,1    AT(A) = CONTENTS OF B INPUT
1347         IAB
1348         JST     DA00    DEFINE AF
1349         JMP*    AF00
1350 AF90    PZE     0
1351 AF91    OCT     107777
1352 *
1353 *
1354 *             *****************
1355 *             *DEFINE LOCATION*
1356 *             *****************
1357 *          SET AF = RPL, AT = REL
1358 LO00    DAC     **
1359         LDA     K101    REL
1360         IAB
1361         LDA     RPL
1362         JST     AF00    DEFINE AF
1363         JMP*    LO00
1364 *             *************************
1365 *             *ASSIGN INTEGER CONSTANT*
1366 *             *************************
1367 *          IM (INTEGER), IU(VARIABLE) , ASSIGN SPECIAL
1368 AI00    DAC     **
1369         CRA
1370         STA     ID+1
1371         STA     ID+2
1372         LDA     K101    (B) = INT
1373         IAB
1374         LDA     K102    (A) = VAR
1375         JST     AA00    ASSIGN SPECIAL
1376         JMP*    AI00    RETURN
1377 *
1378 *
1379 *             ****************
1380 *             *ASSIGN SPECIAL*
1381 *             ****************
1382 *          B REG TO IM, A REG TO IU, 1 TO NT (CONSTANT), THEN
1383 *               ASSIGN ITEM
1384 AA00    DAC     **
1385         STA     IU      IU = (A)
1386         IAB
1387         STA     IM      IM = (B)
1388         LDA     K101
1389         STA     NT      NT = 1
1390         JST     AS00    ASSIGN ITEM
1391         JMP*    AA00    RETURN
1392 *
1393 *
1394 *             **********
1395 *             *JUMP    *
1396 *             *ILL TERM*
1397 *             **********
1398 *
1399 *          CLEAR LAST OP FLAG FOR NO PATH TESTING
1400 *
1401 B6      CRA
1402         STA     LSTP    LSTP = 0
1403 *          SET ILLEGAL DO TERM FLAG
1404 C5      LDA     K101
1405         STA     LSTF    LSTF =1
1406 A1      LDA     CRET
1407         JST     TS00    IF TC NOT C/R, ERROR
1408         JMP     C6
1409 *
1410 *
1411 *             **********
1412 *             *CONTINUE*
1413 *             **********
1414 *          WRAPUP LOGICAL IF, CHECK TRACE STOP AND SEARCH
1415 *               DO TABLE FOR DO TERMINATION
1416 C6      LDA     LIF
1417         SZE             IF LIF NON-ZERO,
1418         JMP     C6H     GO TO
1419 C6A     LDA     LSTN    IF LSTN NON-ZERO,
1420         SZE             GO TO
1421         JMP     C6C
1422 C6B     STA     LSTF    LSTF = 0
1423         JMP     C7      GO TO STATEMENT INPUT
1424 C6C     SUB     TRF     TRACE FLAG
1425         SNZ             SMP IF NOT END OF TRACE ZONE
1426         STA     TRF     SET TRF TO ZERO (TURN FLAG OFF)
1427         LDA     DO      START OF DO TABLE
1428         ADD     D
1429 C6D     STA     I       I = DO + D
1430         JST     STXI
1431         SUB     DO
1432         SNZ
1433         JMP     C6B     GO TO C6B - FINISHED DO
1434         LDA     DP-4,1
1435         SUB     LSTN
1436         SZE
1437         JMP     C6E
1438         LDA     LSTF
1439         SZE
1440         JMP     C6K
1441         JST     DQ00    DO TERMINATION
1442         LDA     D
1443         SUB     K105
1444         STA     D       D = D-5
1445         LDA     LSTF
1446 C6E     STA     LSTF
1447         LDA     I
1448         SUB     K105
1449         JMP     C6D     I = I-5 - CONTINUE DO LOOP
1450 C6H     LDA     IFF
1451         STA     A
1452         SNZ
1453         JMP     C6J
1454         LLL     16
1455         LDA     OMI5    (A) = JMP INSTRUCTION
1456         JST     OB00    OUTPUT OA
1457         CRA
1458         STA     IFF     IFF = 0
1459 C6J     STA     A       A = U
1460         LDA     LIF
1461         STA     LSTP    SET TO NON-ZERO TO PREVENT DATA ERROR MSG
1462         JST     OS00    OUTPUT STRING - RPL
1463         JMP     C6A
1464 *
1465 C6K     JST     ER00
1466         BCI     1,DT
1467 *
1468 *
1469 *
1470 *             *****************
1471 *             *STATEMENT INPUT*
1472 *             *****************
1473 *          SET UP PROCESSING OF NEXT SOURCE STATEMENT
1474 *               PROCESS STATEMENT NUMBER IF PRESENT
1475 *               WRAPUP ANY OUTSTANDING ARITHMETIC IF
1476 C7      CRA
1477         STA     LSTN    LSTN = 0
1478         STA     IFLG    IFLG = 0
1479         STA     LIF     LIF = 0
1480         LDA     L0      L = L (0)
1481         STA     L
1482         LDA     CI      CHECK CARD COLUMN 1
1483         LGR     8       FOR $ CHARACTER
1484         SUB     K15     *($)
1485         SNZ
1486         JMP     CCRD    CONTROL CARD
1487         JST     XN00    EXAMINE NEXT CHAR
1488         SZE
1489         JMP     C71
1490         JST     IS00    INPUT STATEMENT =
1491         LDA     A
1492         STA     LSTN    LSTN = A
1493         STA     LSTP
1494 C71     LDA     IFF     CHECK FOR IFF=0
1495         LDA     IFF     IF IFF = 0,
1496         SNZ
1497         JMP     C7B     GO TO C7B
1498         SUB     LSTN    IF = LSTN
1499         SZE
1500         JMP     C7C
1501 C7A     STA     IFF     IFF = 0
1502 C7B     JST     C7LT    LINE TEST
1503         JMP     C8
1504 C7C     LDA     IFF     IFF = A
1505         STA     A
1506         LRL     32
1507         LDA     K201    (A) = JMP INSTRUCTION
1508         JST     OB00    OUTPUT OA
1509         CRA
1510         JMP     C7A     GO TO C7A
1511 C7LT    DAC     **      LINE TEST
1512         LDA     CI+2    CI = BLANK
1513         ANA     K116    LIST LINE
1514         ADD     K8      RETURN
1515         STA     CI+2
1516         LDA     TC
1517         SUB     HC2     IF TC : SPECIAL
1518         SZE
1519         JMP     C7LU
1520         JST     LIST
1521         JMP*    C7LT
1522 C7LU    JST     ER00    CONSTRUCTION ERROR
1523         BCI     1,SC    STATEMENT NO. ON A CONTINUATION CARD
1524 *
1525 *
1526 *
1527 *             ************************
1528 *             *CONTROL CARD PROCESSOR*
1529 *             ************************
1530 CCRD    JST     FS00    FLUSH BUFFER IF NECESSARY
1531         JST     LIST    LIST CARD
1532         LDA     CI      WORD CONTAINING COLUMN 1
1533         LGL     12
1534         SNZ
1535         LDA     CCRK    ='030000 (EOJ CODE = 3)
1536         LGR     6       TRUNCATE TO A DIGIT
1537         STA     OCI
1538         LDA     K106    =6
1539         STA     OCNT    SET BUFFER WORD COUNT TO 3
1540         JST     FS00    FLUSH BUFFER
1541         LDA     CI
1542         LGL     12      CHECK COLUMN 1 FOR CONTROL CODE 0
1543         SZE
1544         JMP     ER20    SKIP TO NEXT CARD (NOT CONTROL CARD)
1545         CALL    F4$END  CLOSE-OUT I/0 DEVICES AND STOP
1546         JMP     A0      RESTART NEW COMPILATION
1547 CCRK    OCT     030000  EOJ CONTROL CODE
1548 *
1549 *             ****************
1550 *             *STATEMENT SCAN*
1551 *             ****************
1552 *          DETERMINE THE CLASS OF THE STATEMENT
1553 *               IF AN = IS FOUND WITH A FOLLOWING ,
1554 *                    THE STATEMENT IS A DO
1555 *                    IF NO FOLLOWING COMMA, THE PAREN FLAG
1556 *                    IS TESTED, IF NO PARENS, THE STATEMENT
1557 *                    IS ARITHMETIC ASSIGNMENT
1558 *                    IF PARENS WERE DETECTED AND THE FIRST
1559 *                    NAME IS AN ARRAY, THE STATEMENT IS
1560 *                    ARITHMETIC ASSIGNMENT
1561 *                    OTHERWISE, IT IS A STATEMENT FUNCTION
1562 *                    IF NO = IS FOUND, THE STATEMENT IS
1563 *                    PROCESSED FURTHER IN STATEMENT ID
1564 C8T1    PZE     0
1565 C8      LDA     CC      SAVE CC
1566         STA     C8X9
1567         LDA     K101
1568         STA     C8T1    T (1) = 1
1569         CRA
1570         STA     ICSW    ICSW = SIR
1571 C8A     JST     CH00    INPUT CHARACTER
1572 C8B     LDA     TC      IF TC = )
1573         SUB     K4
1574         SZE
1575         JMP     C8C
1576         JST     CH00    INPUT CHAR
1577 C8B2    LDA     DFL     IF DFL NOT ZERO
1578         SZE
1579         JMP     C8B     GO TO C8B
1580 C8B4    LDA     C8X9    RESTORE CC
1581         STA     CC
1582         LDA     K101    IPL
1583         STA     ICSW    ICSW = IPL
1584         JMP     A9      GO TO STATEMENT ID
1585 C8C     LDA     TC      IF TC NOT (,
1586         SUB     K17
1587         SZE
1588         JMP     C8D     GO TO C8D
1589         LDA     C8T1    T1 = T1 - 1
1590         SUB     K101
1591         STA     C8T1
1592 C8C4    SZE             IF T1 = 0
1593         JMP     C8B4
1594         JST     DN00    INPUT DNA
1595         JMP     C8B2    GO TO C8B2
1596 C8D     LDA     TC      IF TC = ,
1597         CAS     K134    ='17 ('FINISHED' CODE FOR COMMA)
1598         JMP     *+2
1599         JMP     C8D2    TC = COMMA
1600         SUB     K5
1601         SZE
1602         JMP     C8E
1603 C8D2    LDA     C8T1    GO TO C8C4,
1604         JMP     C8C4
1605 C8E     LDA     TC      ELSE, IF TC = '/'
1606         SUB     K9
1607         SNZ
1608         JMP     C8B4    GO TO C8B4
1609         LDA     TC
1610         SUB     K18     IF NOT = ,
1611         SZE
1612         JMP     C8A     GO TO C8A
1613         LDA     K107    INPUT 7 CHARACTERS
1614         JST     IA00
1615         LDA     C8X9    RESTORE CC
1616         STA     CC
1617         LDA     K101    IPL
1618         STA     ICSW    ICSW = IPL
1619         LDA     TC
1620         SUB     K5      IF TC NOT,
1621         SZE
1622         JMP     C8G     GO TO C8G
1623         LDA     K102    ELSE, INPUT 2 CHARS
1624         JST     IA00
1625         LDA     IBUF    IF (A) = 'DO'
1626         SUB     K19
1627         SNZ
1628         JMP     *+3
1629         JST     ER00
1630         BCI     1,CM    COMMA OUTSIDE PARENTHESES, NOT IN DO STMNT,
1631         LDA     K104
1632         JST     NP00    FIRST NON-SPEC CHECK
1633         JMP     C9      GO TO DO
1634 C8G     LDA     C8T1    1 IF NO ( TO LEFT OF EQUALS
1635         SZE
1636         JMP     G2      ARITHMETIC ASSIGNMENT STATEMENT
1637         JST     SY00    INPUT SYMBOL
1638         LDA     C8X9
1639         STA     CC      RESTORE CC
1640         LDA     IU      IF IU = SUBR
1641         SUB     K103
1642         SZE
1643         JMP     G1      GO TO ARITH ST. FUNCT,
1644         JMP     G2      OTHERWISE = ASSIGNMENT STATEMENT
1645 C8X9    PZE     0
1646 *
1647 *                       TAPE 2 OF 5 - END
1648         MOR