*DECK     GETSTR
          IDENT  GETSTR 
          TITLE  GETSTR -  GET CHARACTER STRING FROM SOURCE 
  
          COMMENT  GET A CHARACTER STRING 
          SST 
  
*CALL STRUCT
  
          SPACE  4
**        GETSTR -  GET A CHARACTER STRING
* 
*     CALLING SEQUENCE- 
*         GETSTR;                  (FROM SYMPL) 
* 
*     GIVEN-
*         DECPOINT = ACTUAL DECIMAL-POINT CHARACTER (. OR ,)
*         QUOTE = ACTUAL QUOTED LITERAL DELIMITER (" OR '). 
* 
*     DOES- 
*         CLALINE = LINE NUMBER OF FIRST CHARACTER OF TOKEN.
*         CLACOLUMN = COLUMN NUMBER OF FIRST CHARACTER OF TOKEN.
*         CLATYPE = TYPE OF TOKEN  (STATUS LIST TKNTYPE). 
*         CLAVALUE = (AUXILIARY) VALUE. 
*         SAREA = 26-WORD ARRAY CONTAINING CHARACTERS COMPRISING
*           TOKEN, LEFT-JUSTIFIED, BLANK-FILLED.
*         SAREALENGTH = NUMBER OF CHARACTERS IN SAREA.
*         SIGNSW = TRUE IFF ILIT, NLIT OR FLIT WAS SIGNED.
*CALL SSCANREGS 
  
*CALL DIAGNOSE
GETCHR    EJECT 
**        GETCHR -  GET NEXT SOURCE CHARACTER 
* 
*     CALLING SEQUENCE- 
*         GETCHR EOD=<LABEL>
* 
*     GIVEN-
*         A.CHR = ADDRESS OF LAST CHARACTER.
* 
*     DOES- 
*         A.CHR = ADDRESS OF THIS CHARACTER.
*         X.CHR = THIS CHARACTER. 
  
  
 GETCHR   MACROE EOD
          LOCAL  SETUP,NEXT 
 P        SET    *P 
          IFEQ   P,60,3 
          SA.CHR A.CHR+1
          NG     X.CHR,SETUP
 NEXT     BSS    0
          IFEQ   P,45,3 
          SA.CHR A.CHR+B..1 
          NG     X.CHR,SETUP
 NEXT     BSS    0
          IFEQ   P,30,2 
          SA.CHR A.CHR+1
 NEXT     NG     X.CHR,SETUP
          IFEQ   P,15,2 
          SA.CHR A.CHR+B..1 
 NEXT     NG     X.CHR,SETUP
          USE    GETCHR 
 SETUP    CALL   SETLINE
          PL     X.TMP,NEXT        IF NOT END-OF-DATA, CONTINUE 
          EQ     EOD               JUMP TO HANDLE END-OF-DATA 
          USE    *
 GETCHR   ENDM
PUTCHR    EJECT 
**        PUTCHR -  PUT X.CHR INTO TOKEN AREA 
* 
*     CALLING SEQUENCE- 
*         PUTCHR
* 
*     GIVEN-
*         X.CHR = CHARACTER.
* 
*     DOES- 
*         ADDS THE CHARACTER TO THE TOKEN.
  
  
 PUTCHR   MACRO 
          LOCAL  SAVEWORD,NEXT
          LX.SAV 6
          SB.SCT B.SCT-B..1 
          BX.SAV X.SAV+X.CHR
          SB.SAL B.SAL+B..1 
          NG     B.SCT,SAVEWORD 
 NEXT     BSS    0
          USE    PUTCHR 
 SAVEWORD SA.SAV A.SAV+B..1 
          SB.SCT 9
          MX.SAV 0
          EQ     NEXT 
          USE    *
 PUTCHR   ENDM
          TITLE 
  
*     BEGIN EXECUTION 
  
 GETSTR   SUBR
  
*     IF EXCEPTIONAL SITUATION EXISTS, GO HANDLE
  
          SA.LOD EXCEPT            NON-ZERO IFF EXCEPTIONAL SITUATION 
_____     NZ     X.LOD,GETSTR4     IF EXCEPTIONAL SITUATION, GO HANDLE
 GETSTR1  LABEL                    (HERE AFTER SOME EXCEPTIONAL SITS.)
  
*     SET UP PROPER REGISTERS 
  
          SB..1  1                 SET CONSTANT 1 
          MX.STO 0 FALSE
          SA.STO CLAVALU E         CLAVALUE = 0;
          SA.STO SIGNSW            SIGNSW = FALSE;
          SA.LOD =10H              INITIALIZE SAREA 
          BX.STO X.LOD
          LX.SAV X.LOD
          SA.STO SAREA
          DUP    12,2 
          SA.SAV A.STO+B..1 
          SA.STO A.SAV+B..1 
          SA.SAV A.STO+B..1 
          SA.LOD SAREA-1           INITIALIZE A.SAV 
          BX.SAV X.LOD
          SA.SAV A.LOD SAREA-1
          MX.SAV 0                 INITIALIZE X.SAV 
          SB.SCT 9                 INITIALIZE SAVE COUNT
          SA.LOD ACHR              RESTORE AX.CHR 
          SA.CHR X.LOD
          SB.SAL B..0              SAREALENGTH = 0
  
*     SKIP LEADING BLANKS AND/OR ILLEGAL CHARACTERS 
  
1         LOOP1 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.LEAD 
_____       NG     X.LOD,GETSTR3     IF CHR CAN START A TOKEN 
            SB.TMP X.CHR-1R 
            IFTHEN B.TMP"0           IF ILLEGAL CHARACTER 
              * (THIS CHARACTER MAY ONLY BE USED IN A NON-NUMERIC 
              *  LITERAL, IN A COMMENT ENTRY OR ON A COMMENT LINE.
              *  A SPACE IS ASSUMED.) 
              DIAGNOSE F,1002,LINENO,COLNO
              ENDIF.
_____       GETCHR EOD=GETSTR2       SET X.CHR = NEXT CHARACTER 
_           EQ     LOOP1             KEEP LOOKING FOR START OF TOKEN
  
 GETSTR2  LABEL                    (HERE IF IMMEDIATE END-OF-DATA)
          SX.STO /TKNTYPE/EOD      SET CLATYPE
          SA.STO CLATYPE
          SX.STO 0                 AVOID INFINITE LOOP IN -TKNCLAS- 
          SA.STO CLAVLN              JUST AFTER -POLISH-
          SA.STO CLACOMM ENT
___       EQ     GETSTRX           GO EIXT WITH END-OF-DATA 
  
 GETSTR3  LABEL                    (HERE IF X.CHR STARTS A TOKEN) 
  
*     SET CLALINE, CLACOLUMN AND CLAVLN FOR FIRST CHARACTER OF TOKEN
  
          SA.LOD LINENO 
          BX.STO X.LOD
          SA.STO CLALINE
          SA.LOD READLIB
          IFTHEN X.LOD"0           IF READING FROM A LIBRARY
            SB.TMP CPYLINE-7       A.CHR IS IN CPYLINE
          ELSE-                    IF READING SOURCE INPUT
            SB.TMP SRCLINE-7       A.CHR IS IN SRCLINE
            ENDIF.
          SX.STO A.CHR-B.TMP
          SA.STO CLACOLU MN 
          SA.LOD CURRVLN
          BX.STO X.LOD
          SA.STO CLAVLN 
  
*     GUESS THAT THIS STRING CAN RECONSTRUCT THE SOURCE 
*         (I.E. STRING NOT MODIFIED DURING ERROR RECOVERY)
  
          MX.STO 0 FALSE
          SA.STO CLAMOD 
  
*     JUMP ACCORDING TO FIRST CHARACTER 
  
          SA.LOD CHRTBL+X.CHR      PICK UP ENTRY ACCORDING TO CHARACTER 
          UX.LOD B.TMP,X.LOD       GET JUMP OFFSET
_____     JP     GETSTR+B.TMP      JUMP TO APPROPRIATE PROCESSOR
  
  
*     SAVE REGISTERS AND EXIT 
  
 GETSTRX  LABEL                    (HERE WHEN TOKEN SET UP) 
          SX.STO B.SAL             NUMBER OF PUTCHR-S DONE
          SA.STO SAREALE NGTH 
  
                                   LEFT-JUSTIFY, BLANK-FILL LAST WORD 
          SB.SCT B.SCT+B..1        CHR SHIFT COUNT FOR LEFT JUST. 
          SB.TMP B.SCT+B.SCT       20, 18, 16, 14, 12, 10,  8,  6,  4, 2
          SB.SCT B.TMP+B.TMP       40, 36, 32, 28, 24, 20, 16, 12,  8, 4
          SB.TMP B.SCT+B.TMP       60, 54, 48, 42, 36, 30, 24, 18, 12, 6
  
          SB.SCR 60 
          IFTHEN B.TMP"B.SCR       IF X.SAV HAS SOME CHARACTERS 
            MX.TMP 1                 FORM MASK
            SB.TMP B.TMP-B..1 
            AX.TMP X.TMP,B.TMP
            SB.TMP B.TMP+B..1 
            SA.LOD =10H 
            BX.LOD X.TMP*X.LOD
            BX.SAV X.LOD+X.SAV
            LX.SAV X.SAV,B.TMP       LEFT-JUSTIFY LAST WORD 
            SA.SAV A.SAV+B..1        SAVE LAST WORD 
            ENDIF.
  
          SX.STO A.CHR             SAVE A.CHR 
          SA.STO ACHR 
  
*     IF READING FROM LIBRARY, NOT LAST COLUMN
  
          SA.LOD CURRVLN           V.L.N. OF CURRENT LINE 
          BX.STO X.LOD
          SA.STO CLALVLN
          SA.LOD ENDCHRS
          IFTHEN X.LOD"0           SO PLI$CURRENT = 0 
            SX.STO B..0            V.L.N. = 0 
            SA.STO CLAVLN 
          ENDIF.
          SA.LOD READLIB
          IFTHEN X.LOD=0           IF READING SOURCE INPUT
            SB.TMP SRCLINE-7+1       A.CHR IS IN SRCLINE
            SX.STO A.CHR-B.TMP       (THIS COLUMN NO.) - 1
            SA.STO CLALCOL UMN
___         EXIT
            ENDIF.
          SB.TMP CPYLINE-7+1       A.CHR IS IN CPYLINE
          SX.STO A.CHR-B.TMP       (THIS COLUMN NUMBER) - 1 
          SA.STO CLALCOL UMN
          EXIT
          SPACE  4
  
*     EXCEPTIONAL SITUATION-
*         X.LOD (EXCEPT) = EXCEPTION NUMBER.
  
 GETSTR4  LABEL 
          SB.TMP X.LOD             EXCEPTION NUMBER 
1         $BEGIN
          NG     X.LOD,400000B+*   IF ILLEGAL NUMBER, ABORT 
          SB.SCR 3                 MAXIMUM LEGAL EXCEPTION NUMBER 
          GT     B.TMP,B.SCR,400000B+*
1         $END
  
_____     JP     GETSTR5-1+B.TMP   GO HANDLE EXCEPTION
  
 GETSTR5  BSS    0
+         EQ     EXCEPT1           1  FIRST CALL OF GETSTR
+         EQ     EXCEPT2           2  HIT END-OF-DATA 
  
  
 EXCEPT1  EQU    400000B+*         (COBOLSS CALLS SETLINE)
  
  
 EXCEPT2  LABEL                    HIT PREVIOUS END-OF-DATA 
          SX.STO /TKNTYPE/EOD 
          SA.STO CLATYPE
          SX.STO 0                 AVOID INFINITE LOOP IN -TKNCLAS- 
          SA.STO CLAVLN              JUST AFTER -POLISH-
___       EXIT                     EXIT DIRECTLY FROM GETSTR
          TITLE  ALPHA -  COLLECT AW
  
*     SAVED NOTHING 
*     FOUND AN ALPHABETIC CHARACTER 
 ALPHA    LABEL 
          SB.CNT 30+1              TRAILING HYPHEN IS NOT FATAL 
 ALPHA1   LABEL 
          SX.STO /TKNTYPE/AW       MUST BE ASSIGNED WORD
          SA.STO CLATYPE
          SX.TMP 1RB               CHECK FOR BOOLEAN LITERAL
          IX.TMP X.TMP-X.CHR
          NZ     X.TMP,ALPHA1C
          GETCHR  EOD=GETSTRX 
          SX.TMP 1R"
          IX.TMP X.TMP-X.CHR
          ZR     X.TMP,ALPHA1A
          SX.TMP 1R'
          IX.TMP X.TMP-X.CHR
          NZ     X.TMP,ALPHA1B
 ALPHA1A  LABEL 
          SX.STO /TKNTYPE/BLIT
          SA.STO CLATYPE
          EQ    CQT0
          SPACE 3 
 ALPHA1B  LABEL 
          BX.TMP X.CHR
          SX.CHR 1RB
          PUTCHR
          SB.CNT B.CNT-1
          BX.CHR X.TMP             RESTORE CHARACTER AFTER B
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.AW 
          PL     X.LOD,ALPHA2  NON-AW CHARACTER 
 ALPHA1C  LABEL              (HERE AFTER 19 DIGITS; B.CMT IS SET) 
1         LOOP1 
            PUTCHR                   SAVE X.CHR 
___         GETCHR EOD=GETSTRX       SET X.CHR = NEXT CHARACTER 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.AW 
_____       PL     X.LOD,ALPHA2      IF CHR CANNOT BE PART OF AW
            SB.CNT B.CNT-1           DECREMENT MAX. NUMBER OF CHARACTERS
_           NZ     B.CNT,LOOP1       IF LEGAL TO AVE MORE CHARACTERS
  
*     SAVED <31 CHARACTERS> 
*     SET AW
*     FOUND AW-CHARACTER
          MX.SAV 0                 DELETE 31ST CHARACTER
          SB.SCT 9
          * (THIS USER-DEFINED NAME HAS MORE THAN 30 CHARACTERS.
          *  ONLY THE LEFT 30 CHARACTERS ARE USED.) 
          DIAGNOSE F,1033,CLALINE,CLACOLUMN 
  
1         LOOP1 
___         GETCHR EOD=GETSTRX       SET X.CHR = NEXT CHARACTER 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.AW 
_           NG     X.LOD,LOOP1       IF AW-CHARACTER, LOOP
___       EQ     GETSTRX           GO EXIT WITH AW
  
  
*     SAVED <1-31 CHARACTERS> 
*     SET AW
*     FOUND NON AW-CHARACTER
 ALPHA2   LABEL 
          SA.LOD A.CHR-B..1        EXAMINE TRAILING CHARACTER 
          SB.TMP X.LOD-1R-
          IFTHEN B.TMP=0           IF TRAILING CHARACTER WAS HYPHEN 
            * (A HYPHEN CANNOT IMMEDIATELY FOLLOW A NAME. 
            *  AN INTERVENING SPACE IS ASSUMED.)
          SB.TMP 9
          NE     B.TMP,B.SCT,ALPHA2A   IF HYPHEN HAS BEEN STORED
          SA.LOD A.SAV-B..1            RETRIEVE WORD
          BX.SAV X.LOD
          SA.SAV A.LOD
          SA.LOD A.LOD+B..1 
          BX.SAV X.LOD
          SB.SCT B..0-B..1
 ALPHA2A  LABEL 
          SB.SAL B.SAL-B..1 
          SB.SCT B.SCT+B..1  DELETE HYPHEN FROM TOKEN 
          MX.LOD 54 
          BX.SAV X.SAV*X.LOD
          LX.SAV 54 
          SA.CHR A.CHR-B..1  RETREAT OVER THE TRAILING HYPHEN 
          DIAGNOSE W,1039,LINENO,COLNO
          ELSE-                    IF NO TRAILING HYPHEN
            IFTHEN B.CNT=0           IF 31 CHARACTERS SAVED 
              * (THIS USER-DEFINED NAME HAS MORE THAN 30 CHARACTERS.
              *  ONLY THE LEFT 30 CHARACTERS ARE USED.) 
              DIAGNOSE F,1033,CLALINE,CLACOLUMN 
              MX.SAV 0                 DELETE THE 31ST CHARACTER
              SB.SCT 9
              ENDIF.
            CALL   CHKSEPW           CHECK FOR PROPER SEPARATOR 
            ENDIF.                     (WARNING IF APPROPRIATE) 
___       EQ     GETSTRX           GO EXIT WITH AW
          TITLE  CDP -  CHECK FOR DECIMAL-POINT 
  
*     FOUND . OR ,
 CDP      LABEL 
          SX.STO X.CHR             SET VALUES AS IF SEPARATOR 
          SA.STO CLAVALU E
          SX.STO /TKNTYPE/PUNC
          SA.STO CLATYPE
  
          SA.LOD DECPOIN T
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.LOD -X.MSK*X.LOD      CHARACTER, RIGHT-JUSTIFIED, ZERO-FILL
          IX.TMP X.CHR-X.LOD
          IFTHEN X.TMP"0           IF MUST BE SEPARATOR 
            GETCHR EOD=CDPEXIT       SET X.CHR = NEXT CHARACTER 
_____       EQ     CDP1              GO CHECK CHARACTER 
            ENDIF.
          GETCHR EOD=CDPEXIT       SET X.CHR = NEXT CHARACTER 
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.DIGIT
          IFTHEN X.LOD<0           IF DIGIT 
            SB.CNT 18                ALLOW 18 DIGITS
_____       EQ     NUMCDP1           GO GET NLIT
            ENDIF.
  
*     FOUND . OR , FOLLOWED BY NON-DIGIT
 CDP1     LABEL                   (HERE FOR NON DECIMAL-POINT CHARACTER)
          SB.TMP X.CHR-1R 
          SB.SCR X.CHR-1R=
          IFTHEN B.TMP"0           IF NOT SPACE 
           ANDIF B.SCR"0            AND NOT START OF PSEUDO-TEXT DELIM. 
            * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
            *  AN INTERVENING SPACE IS ASSUMED.)
            DIAGNOSE W,1001,LINENO,COLNO
            ENDIF.
  
 CDPEXIT  LABEL 
          SA.LOD CLAVALU E         PUT CHR IN SAREA 
          BX.CHR X.LOD
          PUTCHR
___       EQ     GETSTRX           GO EXIT WITH SEPARATOR 
          TITLE  CHKQLC -  CHECK QUOTED LITERAL CONTINUATION
**        CHKQLC -  CHECK QUOTED LITERAL CONTINUATION 
* 
*     CALLING SEQUENCE- 
*         CALL   CHKQLC 
* 
*     GIVEN-
*         X.CHR = CURRENT CHARACTER.
*         QUOTE = REAL STRING DELIMITER.
* 
*     DOES- 
*         IF FIRST NON-SPACE IS NOT A STRING DELIMITER, 
*           GENERATES A DIAGNOSTIC, AND 
*           LEAVES X.TMP NEGATIVE.
*         IF CONTINUATION IS LEGAL, 
*           LEAVES X.TMP=0. 
  
  
 CHKQLC   SUBR
          SA.LOD QUOTE
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.LOD -X.MSK*X.LOD      CHARACTER, RIGHT-JUSTIFIED, ZERO-FILL
          IX.TMP X.CHR-X.LOD
          IFTHEN X.TMP"0           IF ILLEGAL CONTINUATION
            * (THE FIRST NON SPACE CHARACTER IN A CONTINUED PORTION 
            *  OF A NON-NUMERIC LITERAL IS NOT A QUOTE. 
            *  A PRECEDING QUOTE IS ASSUMED.) 
            DIAGNOSE W,1007,LINENO,COLNO
            MX.TMP 1                 NOTE ERROR 
*         ELSE-                    IF LEGAL CONTINUATION
*           LEAVE X.TMP = 0 
            ENDIF.
          EXIT
          TITLE  CHKSEPF -  CHECK SEPARATOR FOR FATAL DIAGNOSTIC
**        CHKSEPF -  CHECK SEPARATOR FOR FATAL DIAGNOSTIC 
* 
*     CALLING SEQUENCE- 
*         CALL   CHKSEPF
* 
*     GIVEN-
*         X.CHR = FIRST CHARACTER FOLLOWING TOKEN.
* 
*     DOES- 
*         IF X.CHR IS ILLEGAL OR NEEDS AN INTERVENING SPACE,
*           ISSUES A FATAL DIAGNOSTIC.
  
  
 CHKSEPF  SUBR
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.NOBLNK 
          IFTHEN X.LOD\0           IF CHR IS ILLEGAL OR NEEDS BLANK,
            * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
            *  AN INTERVENING SPACE IS ASSUMED.)
            DIAGNOSE F,1016,LINENO,COLNO
            ENDIF.
          EXIT
          TITLE  CHKSEPW -  CHECK SEPARATOR FOR WARNING DIAGNOSTIC
**        CHKSEPW -  CHECK SEPARATOR FOR WARNING DIAGNOSTIC 
* 
*     CALLING SEQUENCE- 
*         CALL   CHKSEPW
* 
*     GIVEN-
*         X.CHR = CHARACTER FOLLOWING TOKN. 
* 
*     DOES- 
*         IF X.CHR IS ILLEGAL OR NEEDS AN INTERVENING SPACE,
*           ISSUES A WARNING DIAGNOSTIC.
  
  
 CHKSEPW  SUBR
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.NOBLNK 
          IFTHEN X.LOD\0           IF CHR IS ILLEGAL OR NEEDS BLANK,
            * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
            *  AN INTERVENING SPACE IS ASSUMED.)
            DIAGNOSE W,1001,LINENO,COLNO
            ENDIF.
          EXIT
          TITLE  CLEARSA -  CLEAR SAREA 
**        CLEARSA -  CLEAR SAREA
* 
*     CALLING SEQUENCE- 
*         CALL   CLEARSA
* 
*     GIVEN-
*         A.SAV = ADDRESS OF LAST-STORED WORD IN SAREA. 
* 
*     DOES- 
*         CLEARS REST OF SAREA TO BLANKS. 
  
  
 CLEARSA  SUBR   (LOCAL)
          SA.LOD =10H 
          BX.SAV X.LOD
          SB.SCR SAREA+25 
1         LOOP1 
            SA.SAV A.SAV+B..1 
            SB.TMP A.SAV
_           NE     B.TMP,B.SCR,LOOP1
          EXIT
          TITLE  CQT -  CHECK FOR QUOTED LITERAL
**        GETQCHR -  GET CHARACTER FOR QUOTED LITERAL 
* 
*     CALLING SEQUENCE- 
*         GETQCHR ERR=<LABEL1>,EOD=<LABEL2> 
* 
*     DOES- 
*         X.CHR = NEXT CHARACTER. 
*         IF ERROR (END-OF-LINE BUT NEXT COL. 7 IS NOT HYPHEN), 
*           JUMPS TO <LABEL1>.
*         IF END-OF-DATA, 
*           JUMPS TO <LABEL2>.
  
  
 GETQCHR  MACROE ERR,EOD
          LOCAL  REDO,NEXT,CHKQ 
 REDO     SA.CHR A.CHR+1
          NG     X.CHR,CHKQ 
 NEXT     BSS    0
          USE    GETQCHR
 CHKQ     ID     X.CHR,REDO        IF JUST DID LAST NON-SPACE 
          OR     X.CHR,ERR         IF EOL AND NO HYPHEN IN NEXT COL. 7
          CALL   SETLINE           SET AX.CHR, X.TMP
         *SAVES AX.SAV, B.SCT, B.CNT
          NG     X.TMP,EOD         IF END-OF-DATA 
          CALL   CHKQLC            CHECK QUOTED LITERAL CONTINUATION
         *SAVES AX.CHR, AX.SAV, B.SCT, B.CNT
          PL     X.TMP,REDO        IF NO ERROR, GO GET CHARACTER
          EQ     NEXT              FIRST NON-SPACE WAS NOT QUOTE
          USE    *
 GETQCHR  ENDM
  
*     FOUND QUOTE OR APOSTROPHE 
 CQT      LABEL 
          SX.STO /TKNTYPE/QLIT
          SA.STO CLATYPE
 CQT0     BSS    0
          SA.LOD QUOTE
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.LOD -X.MSK*X.LOD      CHARACTER, RIGHT-JUSTIFIED, ZERO-FILL
          IX.TMP X.LOD-X.CHR
          IFTHEN X.TMP"0           IF X.CHR IS NOT STRING DELIMITER 
            * (THIS CHARACTER MAY ONLY BE USED IN A NON-NUMERIC LITERAL,
            *  IN A COMMENT ENTRY OR ON A COMMENT LINE. 
            *  A SPACE IS ASSUMED.) 
            DIAGNOSE F,1002,LINENO,COLNO
___         GETCHR EOD=GETSTRX       SKIP THE ILLEGAL CHARACTER 
            SX.STO A.CHR             PREPARE TO TRY AGAIN 
            SA.STO ACHR 
_____       EQ     GETSTR1           TRY AGAIN
            ENDIF.
  
*     FOUND STRING DELIMITER
          SB.CNT 255+1             (+1 TO FALL THROUGH IFF TOO LONG)
1         LOOP1 
                   GETQCHR ERR=CQT3,EOD=CQT2A 
            SA.LOD QUOTE
            AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
            MX.MSK -6                77777777777777777700B
            BX.LOD -X.MSK*X.LOD        CHARACTER, R.J.Z.F.
            IX.TMP X.CHR-X.LOD
            IFTHEN X.TMP=0           IF DELIMITER CHR ENCOUNTERED 
              GETQCHR ERR=CQT3,EOD=CQT2A
              SA.LOD QUOTE
              AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
              MX.MSK -6                77777777777777777700B
              BX.LOD -X.MSK*X.LOD      CHARACTER, R.J.Z.F.
              IX.TMP X.CHR-X.LOD
___           NZ     X.TMP,GETSTRX     IF IT WAS THE RIGHT DELIMITER
              ENDIF.
            PUTCHR
            SB.CNT B.CNT-1           DECREMENT MAX. NUMBER OF CHARACTERS
_           NZ     B.CNT,LOOP1       IF OK TO SAVE MORE CHARACTERS
  
*     SAVED <DELIMITER><255 CHARACTERS> 
*     SET QLIT
*     FOUND QL-CHARACTER
          * (THIS NON-NUMERIC LITERAL HAS MORE THAN 255 CHARACTERS. 
          *  ONLY THE LEFT 255 CHARACTERS ARE USED.)
          DIAGNOSE F,1004,CLALINE,CLACOLUMN 
  
1         LOOP1                    SKIP REST OF LITERAL 
_____       GETQCHR ERR=CQT2,EOD=CQT1 
            SA.LOD QUOTE
            AX.LOD 9*6               RIGHT-JUSTIFY QUOTE CHARACTER
            MX.MSK -6                77777777777777777700B
            BX.LOD -X.MSK*X.LOD      NOW ZERO-FILL QUOTE CHARACTER
            IX.TMP X.CHR-X.LOD
            IFTHEN X.TMP=0         IF DELIMITER FOUND 
_____         GETQCHR ERR=CQT2,EOD=CQT1 
              SA.LOD QUOTE             QUOTE CHARACTER IN SYMPL C(1) FMT
              AX.LOD 9*6               RIGHT-JUSTIFY QUOTE CHARACTER
              MX.MSK -6                77777777777777777700B
              BX.LOD -X.MSK*X.LOD      NOW ZERO-FILL QUOTE CHARACTER
              IX.TMP X.CHR-X.LOD
_             ZR     X.TMP,LOOP1       IF INTERIOR DELIMITER, LOOP
              ENDIF.
  
___       EQ     GETSTRX           GO EXIT WITH QLIT
*     SAVED <DELIMITER><255 CHARACTERS><DELIMITER>
*     SET QLIT
*     FOUND MORE CHARACTERS, THEN END-OF-DATA 
 CQT1     LABEL 
          * (THIS NON-NUMERIC LITERAL HAS MORE THAN 255 CHARACTERS AND
          *  IS ALSO TERMINATED BY END-OF-PROGRAM.
          *  ONLY THE LEFT 255 CHARACTERS ARE USED.)
          DIAGNOSE F,1043,CLALINE,CLACOLUMN 
          SX.STO B0 
          SA.STO CLAVLN 
___       EQ     GETSTRX           GO EXIT WITH QLIT
  
  
*     SAVED <DELIMITER><255 CHARACTERS><DELIMITER>
*     SET QLIT
*     FOUND MORE CHARACTERS, THEN NO HYPHEN CONTINUATION
 CQT2     LABEL 
          * (THIS NON-NUMERIC LITERAL HAS MORE THAN 255 CHARACTERS
          *  AND ALSO NEEDS EITHER A HYPHEN IN COLUMN 7 FOR CONTINUATION
          *  OR A TRUNCATING DELIMITER. 
          *  ONLY THE LEFT 255 CHARACTERS ARE USED.)
          DIAGNOSE F,1045,CLALINE,CLACOLUMN 
_____     EQ     CQT4              GO RECOVER FROM ERROR
  
*     SAVED <DELIMITER><1-254 CHARACTERS> 
*     FOUND END-OF-DATA 
 CQT2A    LABEL 
          SX.STO B0 
          SA.STO CLAVLN 
  
*     SAVED <DELIMITER><1-254 CHARACTERS> 
*     SET QLIT
*     FOUND END-OF-DATA OR ERROR
 CQT3     LABEL 
          * (THIS NON-NUMERIC LITERAL HAS NO TERMINATING QUOTE. 
          *  A QUOTE IN COLUMN 73 IS ASSUMED.)
          DIAGNOSE F,1011,CLALINE,CLACOLUMN 
  
*     RECOVER FROM NO HYPHEN IN THE NEXT COLUMN 7 
 CQT4     LABEL                    (HERE FROM CQT2) 
          CALL   SETLINE
___       PL     X.TMP,GETSTRX     IF NOT END-OF-DATA 
          SX.STO 1R                ENSURE THAT NEXT TOKEN STARTS ANEW 
          SA.STO A.CHR-B..1        (CURRENT A.CHR _ NEGATIVE) 
          SA.CHR A.STO
___       EQ     GETSTRX           GO EXIT WITH QLIT
          TITLE  CTD -  CHECK FOR PSEUDO-TEXT DELIMITER 
  
*     FOUND = 
 CTD      LABEL                    CHECK FOR PSEUDO-TEXT DELIMITER
               SA.LOD A.CHR+1 
               PL     X.LOD,CTD1   THIS = DOESNT END CARD 
               SA.LOD NEWCOL7 
               SB.TMP X.LOD-1R-   IS NEWCOL7 HYPHEN 
               IFTHEN B.TMP=0 
                 GETCHR EOD=SGL 
                 SB.TMP X.CHR-1R= 
                 IFTHEN B.TMP"0   NOT PSEUDO-TEXT 
                   SA.CHR A.CHR-1 
                   EQ     SGL 
                   ENDIF. 
                 DIAGNOSE F,1096,LINENO,COLNO 
                 EQ     CTD2
                 ENDIF. 
 CTD1          LABEL
_____     GETCHR EOD=SGL
          SB.TMP X.CHR-1R=
          IFTHEN B.TMP"0           IF (=,NON-=) 
            SA.CHR A.CHR-1           RETREAT TO THE = 
_____       EQ     SGL               GO PROCESS SINGLE-CHARACTER OP 
            ENDIF.
  
 CTD2          LABEL
*     FOUND ==
          PUTCHR                  PLACE PSEUDO-TEXT-DELIMITER 
          PUTCHR                  IN TOKEN
          SX.STO X.CHR             AND
          SA.STO CLAVALU E         CLAVALUE 
          SX.STO /TKNTYPE/PTDELIM 
          SA.STO CLATYPE
___       GETCHR EOD=GETSTRX       LEAVE CORRECT AX.CHR 
___       EQ     GETSTRX           GO EXIT WITH PTDELIM 
          TITLE  DIAGC -  DIAGNOSE AT CLALINE,CLACOLUMN 
**        DIAGC -  DIAGNOSE AT CLALINE,CLACOLUMN
* 
*     CALLING SEQUENCE- 
*         DIAGNOSE <SEVERITY>,<NUMBER>,CLALINE,CLACOLUMN
*     OR
*         SX.STO <NUMBER> 
*         CALL   DIAGC
* 
*     DOES- 
*         SAVES REGISTERS.
*         ISSUES DIAGNOSTIC.
*         RESTORES REGISTERS. 
  
  
 DIAGC    SUBR
          SX.STO X.STO-1000 
          SA.STO DIAGCB            STORE ERROR NUMBER 
          CALL   SAVE              SAVE RELEVANT REGISTERS
          SA1    DIAGCA            ACTUAL PARAMETER LIST
          CALL   INTERCE PTOR 
          CALL   RESTORE           RESTORE RELEVANT REGISTERS 
          EXIT
  
  
 DIAGCA   CON    CLACOLU MN        ADDRESS OF COLUMN NUMBER 
          CON    CLALINE           ADDRESS OF LINE NUMBER 
          CON    DIAGCB            ADDRESS OF ERROR NUMBER
          CON    *                 ADDRESS OF SEVERITY  (IGNORED) 
  
          CON    0                 (TERMINATE LIST) 
  
 DIAGCB   BSS    1                 ERROR NUMBER 
          TITLE  DIAGL -  DIAGNOSE AT LINENO,COLNO
**        DIAGL -  DIAGNOSE AT LINENO,COLNO 
* 
*     CALLING SEQUENCE- 
*         DIAGNOSE <SEVERITY>,<NUMBER>,LINENO,COLNO 
*     OR
*         SX.STO <NUMBER> 
*         CALL   DIAGL
* 
*     DOES- 
*         SAVES REGISTERS.
*         ISSUES DIAGNOSTIC.
*         RESTORES REGISTERS. 
  
  
 DIAGL    SUBR
          SX.STO X.STO-1000 
          SA.STO DIAGLC            STORE ERROR NUMBER 
          SA.LOD READLIB
          IFTHEN X.LOD"0           IF READING FROM A LIBRARY
            SB.TMP CPYLINE-7       A.CHR IS IN CPYLINE
          ELSE-                    IF READING SOURCE INPUT
            SB.TMP SRCLINE-7       A.CHR IS IN SRCLINE
            ENDIF.
          SX.STO A.CHR-B.TMP
          SA.STO DIAGLB 
          CALL   SAVE              SAVE RELEVANT REGISTERS
          SA1    DIAGLA            ACTUAL PARAMETER LIST
          CALL   INTERCE PTOR      ISSUE DIAGNOSTIC 
          CALL   RESTORE           RESTORE RELEVANT REGISTERS 
          EXIT
  
  
 DIAGLA   CON    DIAGLB            ADDRESS OF COLUMN NUMBER 
          CON    LINENO            ADDRESS OF LINE NUMBER 
          CON    DIAGLC            ADDRESS OF ERROR NUMBER
          CON    *                 ADDRESS OF SEVERITY   (IGNORED)
  
 DIAGLB   BSS    1                 COLUMN NUMBER
 DIAGLC   BSS    1                 ERROR NUMBER 
          EXIT
          TITLE  LPAREN -  HANDLE LEFT PARENTHESIS
*     FOUND ( 
 LPAREN   LABEL 
          SX.STO /TKNTYPE/LP
          SA.STO CLATYPE
          PUTCHR                   SAVE ( IN SAREA
___       GETCHR EOD=GETSTRX       PREPARE FOR NEXT CHARACTER 
___       EQ     GETSTRX           GO EXIT WITH OP
          TITLE  NUM -  COLLECT A NUMBER
*     FOUND DIGIT 
 NUM      LABEL 
  
*     SAVED [<SIGN>]
*     FOUND DIGIT 
 NUM1     LABEL                    (HERE AFTER + OR -)
          SX.STO 0 FALSE
          SA.STO TOOLONG
          SX.STO /TKNTYPE/ILIT     FIRST GUESS IS ILIT
          SA.STO CLATYPE
          SB.CNT 18                COLLECT UP TO 18 DIGITS
1         LOOP1 
            PUTCHR                   SAVE PREVIOUS DIGIT
___         GETCHR EOD=GETSTRX       SET X.CHR = NEXT CHARACTER 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUM10       IF NON-DIGIT 
            SB.CNT B.CNT-1           DECREMENT MAX. NUMBER OF DIGITS
_           NZ     B.CNT,LOOP1       IF ABLE TO PROCESS MORE DIGITS 
  
*     SAVED [<SIGN>]<18 DIGITS> 
*     FOUND 19TH DIGIT
          SA.LOD SIGNSW 
          ZR     X.LOD,NUM8        IF NO SIGN, MIGHT BE AW
  
*     SAVED [<SIGN>]<18 DIGITS> 
*     FOUND 19TH DIGIT
 NUM1A    LABEL 
          SB.CNT 100-18 
 NUM1A1   LABEL              JUMPED HERE WHEN 30TH DIGIT FOUND FROM NUM8
1         LOOP1 
            PUTCHR
_____       GETCHR EOD=NUM2 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUM1B       IF NON-DIGIT 
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
*     SAVED [<SIGN>]<100 DIGITS>
*     WILL NOT RECOVER EVEN IF FLOATING POINT LITERAL 
          SX.STO 1 TRUE 
          SA.STO TOOLONG
  
1         LOOP1 
_____       GETCHR EOD=NUM2 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_           NG     X.LOD,LOOP1
  
*     SAVED [<SIGN>]<19-100 DIGITS> 
*     SKIPPED MORE DIGITS IFF TOOLONG = TRUE. 
 NUM1B    LABEL                    (HERE FROM @100 DIGITS)
          SA.LOD DECPOIN T
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.LOD -X.MSK*X.LOD      CHARACTER, RIGHT-JUSTIFIED, ZERO-FILL
          IX.TMP X.CHR-X.LOD
_____     ZR     X.TMP,NUM3        IF DECIMAL POINT 
  
*     SAVED [<SIGN>]<19-100 DIGITS> 
*     FOUND NON-DECIMAL-POINT 
 NUM1C    LABEL 
          CALL   CHKSEPF
 NUM2     LABEL                    (HERE WHEN END-OF-DATA)
          SA.LOD SIGNSW 
          IFTHEN X.LOD"0           IF SIGNED
            SA.LOD SAREA             POINT A.SAV TO FIRST WORD
            BX.SAV X.LOD
            SA.SAV A.LOD SAREA       <SIGN><9 DIGITS> 
            SA.LOD A.LOD+B..1 SAREA+1 
            MX.MSK 6
            AX.LOD 6
            BX.SAV -X.MSK*X.LOD 
            SB.SCT B..0 
            * (THIS SIGNED INTEGER LITERAL HAS MORE THAN 18 DIGITS. 
            *  ONLY THE LEFT 18 DIGITS ARE USED.) 
            DIAGNOSE F,1009,CLALINE,CLACOLUMN 
          ELSE-                    IF UNSIGNED
            SA.LOD SAREA             POINT A.SAV TO FIRST WORD
            BX.SAV X.LOD
            SA.SAV A.LOD SAREA       <10 DIGITS>
            SA.LOD A.LOD+B..1 SAREA+1 
            MX.MSK 2*6
            AX.LOD 2*6
            BX.SAV -X.MSK*X.LOD 
            SB.SCT B..1 
            * (THIS UNSIGNED INTEGER LITERAL HAS MORE THAN 18 DIGITS. 
            *  ONLY THE LEFT 18 DIGITS ARE USED.) 
            DIAGNOSE F,1042,CLALINE,CLACOLUMN 
            ENDIF.
          SX.STO /TKNTYPE/ILIT
          SA.STO CLATYPE
___       EQ     GETSTRX           GO EXIT WITH ILIT
  
  
*     SAVED [<SIGN>]<19-100 DIGITS> 
*     FOUND EITHER DECIMAL-POINT OR A SEPARATOR (IF LAST) 
 NUM3     LABEL 
          PUTCHR                   SAVE POSSIBLE DECIMAL-POINT
_____     GETCHR EOD=NUM2 
          SB.TMP X.CHR-1RE
          ZR     B.TMP,NUM6 
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.DIGIT
_____     NG     X.LOD,NUM4        IF NUMERIC LITERAL 
  
*     SAVED [<SIGN>]<19-100 DIGITS><SEPARATOR>
          SA.CHR A.CHR-1           RETREAT BEFORE SEPARATOR IN SOURCE 
_____     EQ     NUM2              STRIP ALL BUT 18 DIGITS
  
  
*     SAVED [<SIGN>]<19-200 DIGITS><DECIMAL-POINT>
*     FOUND ANOTHER DIGIT 
 NUM4     LABEL 
          SX.STO /TKNTYPE/NLIT
          SA.STO CLATYPE
          SB.CNT 100
1         LOOP1 
            PUTCHR
_____       GETCHR EOD=NUM5 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUM5      IF NON-DIGIT 
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
*     SAVED [<SIGN>]<19-100 DIGITS><DECIMAL-POINT><100 DIGITS>
*     FOUND ANOTHER DIGIT 
*     WILL NOT RECOVER EVEN IF FLOATING POINT LITERAL 
          SX.STO 1 TRUE 
          SA.STO TOOLONG
  
1         LOOP1 
_____       GETCHR EOD=NUM5 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_           NG     X.LOD,LOOP1
*     SAVED [<SIGN>]<19-100 DIGITS><DECIMAL-POINT><100 DIGITS>
*     SKIPPED MORE DIGITS IFF TOOLONG = TRUE
*     FOUND A NON-DIGIT 
          SB.TMP X.CHR-1RE
_____     ZR     B.TMP,NUM6 
 NUM5     LABEL                    (HERE FOR EOD) 
          CALL   CHKSEPF
          SA.LOD SIGNSW 
          IFTHEN X.LOD"0           IF SIGNED
            SA.LOD SAREA           POINT S.SAV TO FIRST WORD
            BX.SAV X.LOD
            SA.SAV A.LOD SAREA       <SIGN><9 DIGITS> 
            SA.LOD A.LOD+B..1 SAREA+1 
            MX.MSK 6
            AX.LOD 6
            BX.SAV -X.MSK*X.LOD 
            SB.SCT B..0 
            SB.SAL 18 
            * (THIS SIGNED NUMERIC LITERAL HAS MORE THAN 18 DIGITS. 
            *  ONLY THE LEFT 18 DIGITS ARE USED.) 
            DIAGNOSE F,1010,CLALINE,CLACOLUMN 
          ELSE-                    IF UNSIGNED
            SA.LOD SAREA             POINT A.SAV TO FIRST WORD
            BX.SAV X.LOD
            SA.SAV A.LOD SAREA       <10 DIGITS>
            SA.LOD A.LOD+B..1 SAREA+1 
            MX.MSK 2*6
            AX.LOD 2*6
            BX.SAV -X.MSK*X.LOD 
            SB.SCT B..1 
            SB.SAL 18 
            * (THIS UNSIGNED NUMERIC LITERAL HAS MORE THAN 18 DIGITS. 
            *  ONLY THE LEFT 18 DIGITS ARE USED.) 
            DIAGNOSE F,1024,CLALINE,CLACOLUMN 
            ENDIF.
          SX.STO /TKNTYPE/ILIT
          SA.STO CLATYPE
___       EQ     GETSTRX           GO EXIT WITH ILIT
  
  
*     SAVED [<SIGN>]<19-100 DIGITS><DECIMAL-POINT><100 DIGITS>
*     SKIPPED MORE DIGITS IFF TOOLONG = TRUE. 
*     FOUND AN E
 NUM6     LABEL 
          SX.STO /TKNTYPE/FLIT
          SA.STO CLATYPE
          PUTCHR                   SAVE THE E 
          SB.CNT 10 
1         LOOP1 
_____       GETCHR EOD=NUM7 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUM7        IF NON-DIGIT 
            PUTCHR
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
          SX.STO 1                 NOTE IRRECOVERABLE FLIT
          SA.STO TOOLONG
1         LOOP1 
_____       GETCHR EOD=NUM7 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_           NG     X.LOD,LOOP1
  
*     SAVED [<SIGN>]<19-100 DIGITS><DECIMAL-POINT><1-100 DIGITS>E<0-10D>
*     SKIPPED MORE DIGITS IFF TOOLONG = TRUE. 
*     FOUND A NON-DIGIT 
 NUM7     LABEL                    (HERE FOR EOD) 
          SA.LOD TOOLONG
          IFTHEN X.LOD"0           IF CANNOT RECOVER
            SA.LOD SAREA-1           POINT S.SAV TO 0TH WORD
            BX.SAV X.LOD
            SA.SAV A.LOD SAREA-1
            CALL   CLEARSA           BLANK-FILL REMAINDER OF SAREA
            SA.SAV SAREA
            SA.LOD =5R1.0E0 
            BX.SAV X.LOD
            SB.SCT 4                 NOTE 5 CHARACTERS IN X.SAV 
            SB.SAL 5
            SA.LOD SIGNSW 
            IFTHEN X.LOD"0           IF SIGNED
              * (THIS SIGNED FLOATING POINT LITERAL IS MUCH TOO LONG. 
              *  A VALUE OF 1.0E0 IS ASSUMED.)
              DIAGNOSE F,1023,CLALINE,CLACOLUMN 
            ELSE-                    IF UNSIGNED
              * (THIS UNSIGNED FLOATING POINT LITERAL IS MUCH TOO LONG. 
              *  A VALUE OF 1.0E0 IS ASSUMED.)
              DIAGNOSE F,1028,CLALINE,CLACOLUMN 
              ENDIF.
            ENDIF.
  
          SX.STO /TKNTYPE/FLIT
          SA.STO CLATYPE
___       EQ     GETSTRX           GO EXIT WITH FLIT
  
  
*     SAVED <18 DIGITS> 
*     FOUND 19TH DIGIT
 NUM8     LABEL 
          SB.CNT 12 
1         LOOP1 
            PUTCHR                   SAVE X.CHR 
 _____      GETCHR EOD=NUM2          SET X.CHR = NEXT CHARACTER 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
            PL     X.LOD,NUM9        IF NON-DIGIT 
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
*     SAVED <30 DIGITS> 
*     FOUND 31ST DIGIT
          SA.LOD ILITISP NREF 
          IFTHEN X.LOD"0           ILIT CAN BE AW 
            SB.CNT 1               31 
            EQ     ALPHA1C
            ENDIF.
          SA.LOD CLACOLU MN 
          SX.LOD X.LOD-12 
          IFTHEN X.LOD<0           ILIT BEFORE COL 12 IS AW 
            SB.CNT 1               31 
            EQ     ALPHA1C
            ENDIF.
          SB.CNT 100-31 
          EQ     NUM1A1 
  
  
*     SAVED <19-30 DIGITS>
*     FOUND NON-DIGIT 
 NUM9     LABEL 
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.AW 
          SX.STO    /TKNTYPE/AW 
          SA.STO    CLATYPE 
          NG     X.LOD,ALPHA1C     GO HANDLE AW 
          SX.STO    /TKNTYPE/ILIT 
          SA.STO    CLATYPE 
          SA.LOD DECPOIN T
          AX.LOD 9*6
          MX.MSK -6 
          BX.STO -X.MSK*X.LOD 
          IX.TMP X.CHR-X.STO
          NZ     X.TMP,NUM9C       IF NOT DECIMAL POINT 
  
*     SAVED <19-30 DIGITS>
*     FOUND . OR ,
          SA.STO DIGIT       SAVE POSSIBLE DECIMAL POINT
          GETCHR EOD=NUM2 
          SB.TMP X.CHR-1RE
          NZ     B.TMP,NUM9A IF NOT E FOLLOWING POSSIBLE DECIMAL POINT
          SA.LOD DIGIT
          SX.CHR X.LOD
          PUTCHR             PLACE DECIMAL POINT IN TOKEN 
          SA.CHR A.CHR       RESTORE E
          EQ     NUM6        FLIT 
 NUM9A    LABEL 
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.DIGIT
          PL     X.LOD,NUM9B IF NOT A DIGIT AFTER POSSIBLE DECIMAL PT.
          SA.LOD DIGIT
          SX.CHR X.LOD
          PUTCHR             PLACE DECIMAL POINT IN TOKEN 
          SA.CHR A.CHR       RESTORE DIGIT
          EQ     NUM4        NLIT 
 NUM9B    LABEL 
          SA.CHR A.CHR-1     RESTORE PERIOD OR COMMA
  
*     SAVED <19-30 DIGITS > 
*     FOUND NON-DIGIT 
 NUM9C    LABEL 
          SA.LOD ILITISP NREF 
          NZ     X.LOD,ALPHA2      ILIT CAN BE A AW 
          SA.LOD CLACOLU MN 
          SX.LOD X.LOD-12 
          NG     X.LOD,ALPHA2      ILIT BEFORE COL 12 IS A PNDEF
          SA.LOD ALLOWLR GILIT
          NZ     X.LOD,ALPHA2 
          EQ     NUM1C
  
  
*     SAVED [<SIGN>]<1-18 DIGITS> 
 NUM10    LABEL 
          LX.LOD S.NUM-S.DIGIT
          UX.LOD B.TMP,X.LOD
_____     JP     NUM+B.TMP         JUMP ACCORDING TO CHARACTER
NUMALP    SPACE  4
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND A LETTER
 NUMALP   LABEL 
          SA.LOD SIGNSW            1 (TRUE) IFF SIGN CHARACTER SAVED
          NZ     X.LOD,NUMALP2     IF PRECEDED BY SIGN
 NUMALP1  LABEL                    (RECOVER FROM <SIGN><DIGITS><LETTER> 
                                                            OR <HYPHEN>)
  
*     SAVED <1-18 DIGITS> 
*     FOUND LETTER OR HYPHEN
          SX.STO /TKNTYPE/AW       SET CLATYPE = AW 
          SA.STO CLATYPE
  
*     SAVED <1-18 DIGITS> 
*     SET AW
*     FOUND LETTER OR HYPHEN
          SB.CNT B.CNT+12+1        NAMES MAY HAVE 12 MORE CHARACTERS
                                     (TRAILING HYPHEN NOT FATAL)
1         LOOP1 
            PUTCHR                   SAVE X.CHR 
___         GETCHR EOD=GETSTRX       SET X.CHR = NEXT CHARACTER 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.AW 
            PL     X.LOD,ALPHA2      IF CANNOT BE PART OF AW
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1       IF LEGAL TO SAVE MORE CHARACTERS 
  
*     SAVED <31 CHARACTERS> 
*     SET AW
*     FOUND ANOTHER AW-CHARACTER
          MX.SAV 0                 DELETE 31ST CHARACTER
          SB.SCT 9
          * (THIS USER-DEFINED NAME IS LONGER THAN 30 CHARACTERS. 
          *  ONLY THE LEFT 30 CHARACTERS ARE USED.) 
          DIAGNOSE F,1033,CLALINE,CLACOLUMN 
  
1         LOOP1                    SKIP THE REST OF THE AW-CHARACTERS 
___         GETCHR EOD=GETSTRX       SET X.CHR = NEXT CHARACTER 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.AW 
_           NG     X.LOD,LOOP1       IF AW-CHARACTER, LOOP
  
          SB.TMP X.CHR-1R-
          IFTHEN B.TMP=0           IF TRAILING HYPHEN,
            SA.CHR A.CHR-1           DELETE THE HYPHEN
            ENDIF.
___       EQ     GETSTRX           GO EXIT WITH AW
  
  
*     SAVED <SIGN><1-18 DIGITS> 
*     18-B.CNT = NUMBER OF SAVED DIGITS 
*     SET ILIT
*     FOUND A LETTER OR A HYPHEN
 NUMALP2  LABEL               (ALSO HERE IF <SIGN><1-18 DIGITS><HYPHEN>)
          * (THIS CHARACTER MAY NOT FOLLOW THE PREDEDING CHARACTER. 
          *  AN INTERVENING SPACE IS ASSUMED.)
          DIAGNOSE  W,1001,LINENO,COLNO 
___       EQ     GETSTRX           EXIT WITH SIGNED ILIT
NUMCDP    SPACE  4
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     FOUND DECIMAL-POINT OR SEPARATOR  (, OR .)
 NUMCDP   LABEL 
          SA.LOD DECPOIN T
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.LOD -X.MSK*X.LOD      CHARACTER, RIGHT-JUSTIFIED, ZERO-FILL
          IX.TMP X.CHR-X.LOD
___       NZ     X.TMP,GETSTRX     IF MUST BE SEPARATOR, GO EXIT
___       GETCHR EOD=GETSTRX       IF EOD, EXIT WITH ILIT 
          SB.TMP X.CHR-1RE
          ZR     B.TMP,NUMCDP0
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.DIGIT
_____     NG     X.LOD,NUMCDP1     IF PREVIOUS WAS DECIMAL-POINT
  
          SA.CHR A.CHR-1           RETREAT BEFORE SEPARATOR IN SOURCE 
___       EQ     GETSTRX           GO EXIT WITH ILIT
  
*    SAVE DECIMAL POINT 
 NUMCDP0  BX.STO X.CHR       PRESERVE E 
          SA.STO DIGIT
          SA.LOD DECPOIN T
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.CHR -X.MSK*X.LOD      CHAR, RIGHT-JUSTIFIED, ZERO FILL 
          PUTCHR                   SAVE DECIMAL-POINT 
          SA.LOD DIGIT
          BX.CHR X.LOD       RESTORE E
          EQ     NUMCDP8
  
*     SAVED [<SIGN>]<0-18 DIGITS> 
*     FOUND DECIMAL-POINT FOLLOWED BY DIGIT 
 NUMCDP1  LABEL                    (ALSO HERE FROM CDP AND SIGNCDP) 
          SX.STO /TKNTYPE/NLIT     LATEST GUESS IS NLIT 
          SA.STO CLATYPE
          BX.STO X.CHR             PRESERVE DIGIT 
          SA.STO DIGIT
          SA.LOD DECPOIN T
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.CHR -X.MSK*X.LOD      CHARACTER, RIGHT-JUSTIFIED, ZERO-FILL
          PUTCHR                   SAVE DECIMAL-POINT 
          SA.LOD DIGIT
          BX.CHR X.LOD
_____     ZR     B.CNT,NUMCDP2     IF 18 DIGITS BEFORE DECIMAL-POINT
1         LOOP1 
            PUTCHR
___         GETCHR EOD=GETSTRX
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUMCDP7   IF NON-DIGIT 
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
*     SAVED [<SIGN>]<0-18 DIGITS><DECIMAL-POINT><18-0 DIGITS> 
*     SET NLIT
*     FOUND ANOTHER DIGIT 
 NUMCDP2  LABEL 
          SB.CNT 200
1         LOOP1 
            PUTCHR
_____       GETCHR EOD=NUMCDP3A 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUMCDP3   IF NON-DIGIT 
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
*     SAVED [<SIGN>]<0-18 DIGITS><DECIMAL-POINT><217-201 DIGITS>
*     SET NLIT
*     FOUND ANOTHER DIGIT 
          SX.STO 1 TRUE            SET TOOLONG IN CASE OF FLIT
          SA.STO TOOLONG
1         LOOP1 
_____       GETCHR EOD=NUMCDP3A 
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_           NG     X.LOD,LOOP1     IF DIGIT 
  
*     SAVED [<SIGN>]<0-18 DIGITS><DECIMAL-POINT><DIGITS>
*       (MORE THAN 18 DIGITS) 
*     FOUND A NON-DIGIT 
 NUMCDP3  LABEL 
          SB.TMP X.CHR-1RE
_____     ZR     B.TMP,NUMCDP4     IF FLOATING-POINT LITERAL
  
          CALL   CHKSEPF           FATAL ERROR IF NEXT CHAR. WAS ILLEGAL
 NUMCDP3A LABEL                    (HERE FOR EOD) 
          SA.LOD SIGNSW 
          IFTHEN X.LOD"0           IF SIGNED
            SA.LOD SAREA+1         POINT A.SAV TO SECOND WORD 
            BX.SAV X.LOD
            SA.SAV A.LOD SAREA+1
            CALL   CLEARSA           CLEAR REST OF SREA TO BLANKS 
            MX.SAV 0                 LEAVE NO CHARACTERS IN X.SAV 
            SB.SCT 9
            * (THIS SIGNED NUMERIC LITERAL HAS MORE THAN 18 DIGITS. 
            *  ONLY THE LEFT 18 DIGITS ARE USED.) 
            DIAGNOSE F,1010,CLALINE,CLACOLUMN 
          ELSE-                    IF UNSIGNED
            SA.LOD SAREA+1   POINT A.SAV TO SECOND WORD 
            BX.SAV X.LOD
            SA.SAV A.LOD     SAREA+1
            MX.SAV  0        LEAVE NO CHARACTERS IN X.SAV 
            SB.SCT  9 
            * (THIS UNSIGNED NUMERIC LITERAL HAS MORE THAN 18 DIGITS. 
            *  ONLY THE LEFT 18 DIGITS ARE USED.) 
            DIAGNOSE F,1024,CLALINE,CLACOLUMN 
            ENDIF.
___       EQ     GETSTRX           GO EXIT WITH NLIT
  
  
*     SAVED [<SIGN>]<0-17 DIGITS><DECIMAL-POINT><217-201 DIGITS>
*     SKIPPED MORE DIGITS IFF TOOLONG = TRUE. 
*     FOUND AN E. 
 NUMCDP4  LABEL 
          SX.STO /TKNTYPE/FLIT
          SA.STO CLATYPE
          PUTCHR                   SAVE THE E 
          SB.CNT 10 
1         LOOP1 
_____       GETCHR EOD=NUMCDP6
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUMCDP6   IF NON-DIGIT 
            PUTCHR
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
*     SAVED [<SIGN>]<0-17 DIGITS><DECIMAL-POINT><217-0DIGITS>E[10DIGITS>
*     SET FLIT
 NUMCDP5  LABEL                    (HERE FROM JUST AFTER NUMCDP8) 
          SX.STO 1 TRUE 
          SA.STO TOOLONG
1         LOOP1 
_____       GETCHR EOD=NUMCDP6
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_           NG     X.LOD,LOOP1
  
*     SAVED [<SIGN>]<0-17 DIGITS><DECIMAL-POINT><217-201 DIGITS>E<0-10D>
*     SKIPPED MORE DIGITS IFF TOOLONG = TRUE. 
*     FOUND A NON-DIGIT OR EOD
 NUMCDP6  LABEL 
          CALL   CHKSEPF
          SA.LOD TOOLONG
          IFTHEN X.LOD"0           IF CANNOT RECOVER
            SA.LOD SIGNSW 
            IFTHEN X.LOD"0           IF SIGNED
              * (THIS SIGNED FLOATING POINT LITERAL IS MUCH TOO LONG. 
              *  A VALUE OF 1.0E0 IS USED.) 
              DIAGNOSE F,1023,CLALINE,CLACOLUMN 
            ELSE-                    IF UNSIGNED
              * (THIS UNSIGNED FLOATING POINT LITERAL IS MUCH TOO LONG. 
              *  A VALUE OF 1.0E0 IS USED.) 
              DIAGNOSE F,1028,CLALINE,CLACOLUMN 
              ENDIF.
            SA.SAV SAREA
            CALL   CLEARSA   CLEAR SAREA TO BLANKS
            SA.SAV SAREA     CLEAR FIRST WORD OF SAREA TO BLANKS
            SA.LOD =5R1.0E0 
            BX.SAV X.LOD
            SB.SCT 4
            SB.SAL 5
            ENDIF.
___       EQ     GETSTRX           GO EXIT WITH FLIT
  
  
*     SAVED [<SIGN>]<0-18 DIGITS><DECIMAL-POINT><18-0 DIGITS> 
*       (TOTAL OF 1-18 DIGITS)
*     SET NLIT
*     FOUND A NON-DIGIT 
 NUMCDP7  LABEL 
          SB.TMP X.CHR-1RE
_____     ZR     B.TMP,NUMCDP8     IF CHR = E, GO HANDLE FLIT 
          CALL   CHKSEPF     MAYBE FATAL DIAG ABOUT THE NON-DIGIT 
___       EQ     GETSTRX           GO EXIT WITH NLIT
  
  
*     SAVED [<SIGN>]<0-17 DIGITS><DECIMAL-POINT><17-1 DIGITS> 
*       (TOTAL OF 1-18 DIGITS)
*     FOUND AN E
 NUMCDP8  LABEL 
          SX.STO /TKNTYPE/FLIT
          SA.STO CLATYPE
          PUTCHR                   SAVE THE E 
___       GETCHR EOD=GETSTRX       SKIP THE E 
          SB.TMP X.CHR-1R+
          IFTHEN B.TMP=0           IF CHR IS +
            PUTCHR                   SAVE IT
___         GETCHR EOD=GETSTRX       AND GET NEXT CHR (DIGIT) 
          ELSE-                    IF CHR IS NOT +
            SB.TMP X.CHR-1R-
            IFTHEN B.TMP=0           IF CHR IS -
              PUTCHR                   SAVE IT
                   GETCHR EOD=GETSTRX 
              ENDIF.
            ENDIF.
  
          SB.CNT 10 
1         LOOP1 
            PUTCHR
___         GETCHR EOD=GETSTRX
            SA.LOD CHRTBL+X.CHR 
            LX.LOD S.DIGIT
_____       PL     X.LOD,NUMCDP9     IF NON-DIGIT 
            SB.CNT B.CNT-1
_           NZ     B.CNT,LOOP1
  
*     SAVED [<SIGN>]<0-18 DIGITS><DECIMAL-POINT><18-0 DIGITS>E<0-9 DIGS>
*     (TOTAL OF 1-18 DIGITS)
*     FOUND ANOTHER DIGIT 
_____     EQ     NUMCDP5
  
*     SAVED [<SIGN>]<0-18 DIGITS><DECIMAL-POINT><18-0 DIGITS>E<0-9 DIGS>
*     (TOTAL OF 1-18 DIGITS)
*     FOUND A NON-DIGIT 
 NUMCDP9  LABEL 
          CALL   CHKSEPF
___       EQ     GETSTRX           GO EXIT WITH FLIT
NUMCSD    SPACE  4,13 
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND = 
 NUMCTD   LABEL                    CHECK FOR PSEUDO-TEXT DELIMITER
_____     GETCHR EOD=NUMCTD1       SET X.CHR = NEXT CHARACTER 
          SB.TMP X.CHR-1R=
          SA.CHR A.CHR-1           RETREAT TO (FIRST) = 
___       ZR     B.TMP,GETSTRX     IF ==, GO EXIT WITH ILIT 
 NUMCTD1  LABEL                    (HERE IF (=,EOD))
          * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
          *  AN INTERVENING SPACE IS ASSUMED.)
          DIAGNOSE F,1016,LINENO,COLNO
___       EQ     GETSTRX           GO EXIT WITH ILIT
NUMCQT    SPACE  4,16 
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND " OR '
 NUMCQT   LABEL 
          SA.LOD QUOTE
          AX.LOD 9*6               RIGHT-JUSTIFY CHARACTER
          MX.MSK -6                77777777777777777700B
          BX.LOD -X.MSK*X.LOD      CHARACTER, RIGHT-JUSTIFIED, ZERO-FILL
          IX.TMP X.CHR-X.LOD
          IFTHEN X.TMP=0           IF STRING DELIMITER
            * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
            *  AN INTERVENING SPACE IS ASSUMED.)
            DIAGNOSE W,1001,LINENO,COLNO
          ELSE-                    IF ILLEGAL CHARACTER 
            * (THIS CHARACTER MAY ONLY BE USED IN A NON-NUMERIC LITERAL,
            *  IN A COMMENT-ENTRY OR ON A COMMENT LINE. 
            *  A SPACE IS ASSUMED.) 
            DIAGNOSE F,1002,LINENO,COLNO
            GETCHR EOD=GETSTRX
            ENDIF.
___       EQ     GETSTRX           GO EXIT WITH ILIT
NUMFTL    SPACE  4,8
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND ( 
 NUMFTL   LABEL 
          * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
          *  AN INTERVENING SPACE IS ASSUMED.)
          DIAGNOSE F,1016,LINENO,COLNO
___       EQ     GETSTRX           GO EXIT WITH ILIT
NUMHYPH   SPACE  4,11 
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND HYPHEN
 NUMHYPH  LABEL 
          SA.LOD SIGNSW            1 (TRUE) IFF SIGNED
_____     NZ     X.LOD,NUMALP2     IF SIGNED
  
*     SAVED <1-18 DIGITS> 
*     SET ILIT
*     FOUND HYPHEN
_____     EQ     NUMALP1
NUMILL    SPACE  4,8
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND ILLEGAL CHARACTER 
 NUMILL   LABEL 
          * (THIS CHARACTER MAY ONLY BE USED IN A NON-NUMERIC LITERAL,
          *  IN A COMMENT-ENTRY OR ON A COMMENT LINE. 
          *  A SPACE IS ASSUMED.) 
          DIAGNOSE F,1002,LINENO,COLNO
          GETCHR EOD=GETSTRX
___       EQ     GETSTRX           GO EXIT WITH ILIT
NUMOK     SPACE  4,4
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND BLANK OR )
 NUMOK    EQU    GETSTRX           GO EXIT WITH ILIT
NUMWRN    SPACE  4,8
*     SAVED [<SIGN>]<1-18 DIGITS> 
*     SET ILIT
*     FOUND +, *, /, < OR > 
 NUMWRN   LABEL 
          * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
          *  AN INTERVENING SPACE IS ASSUMED.)
          DIAGNOSE W,1001,LINENO,COLNO
___       EQ     GETSTRX           GO EXIT WITH ILIT
          TITLE  PUNC -  FOUND A SEMICOLON
  
*     SAVED NOTHING 
*     FOUND SEMICOLON 
 PUNC     LABEL 
          SX.STO /TKNTYPE/PUNC
          SA.STO CLATYPE
          PUTCHR                   PUT ; IN SAREA 
___       GETCHR EOD=GETSTRX       ADVANCE TO NEXT CHR FOR NEXT TIME
___       EQ     GETSTRX           GO EXIT WITH PUNC
          TITLE  RESTORE -  RESTORE RELEVANT REGISTERS
**        RESTORE -  RESTORE RELEVANT REGISTER
* 
*     CALLING SEQUENCE- 
*         CALL   RESTORE
* 
*     DOES- 
*         RESTORES A.CHR (X.CHR), A.SAV, X.SAV, B.CNT, B.SCT, B..1
  
  
 RESTORE  SUBR   (LOCAL)
          SA.LOD A=SAV
          SA.LOD X.LOD
          BX.SAV X.LOD
          SA.SAV A.LOD
          SA.LOD X=SAV
          BX.SAV X.LOD
          SA.LOD A=CHR
          SA.CHR X.LOD
          SA.LOD B=CNT
          SA.TMP B=SCT
          SB.CNT X.LOD
          SB.SCT X.TMP
          SA.LOD B=SAL
          SB.SAL X.LOD
          SB..1  1
          EXIT
          TITLE  RPAREN -  HANDLE RIGHT PARENTHESIS 
*     FOUND ) 
 RPAREN   LABEL 
          SX.STO /TKNTYPE/RP
          SA.STO CLATYPE
          PUTCHR                   SAVE ) IN SAREA
___       GETCHR EOD=GETSTRX       EXAMINE NEXT CHARACTER 
          CALL   CHKSEPW           IF CHR NEEDED BLANK, WARN
___       EQ     GETSTRX           EXIT WITH RP 
          TITLE  SAVE -  SAVE RELEVANT REGISTERS
**        SAVE -  SAVE RELEVANT REGISTERS 
* 
*     CALLING SEQUENCE- 
*         CALL   SAVE 
* 
*     DOES- 
*         SAVES A.CHR (X.CHR), A.SAV, X.SAV, B.CNT, B.SCT 
  
  
 SAVE     SUBR   (LOCAL)
          SX.STO A.SAV
          SA.STO A=SAV
          SA.SAV X=SAV
          SX.STO A.CHR
          SX.SAV B.CNT
          SA.STO A=CHR
          SA.SAV B=CNT
          SX.STO B.SCT
          SA.STO B=SCT
          SX.STO B.SAL
          SA.STO B=SAL
          EXIT
          TITLE  SGL -  SINGLE-CHARACTER TOKEN
  
*     FOUND A SINGLE-CHARACTER OPERATOR   (I.E. / ( ) < > =)
 SGL      LABEL 
          SX.STO /TKNTYPE/OP       CLATYPE = OPERATOR 
          SA.STO CLATYPE
          SX.STO X.CHR             NOTE WHICH OPERATOR
          SA.STO CLAVALU E
          PUTCHR                   SAVE OPERATOR CHR IN SAREA 
___       GETCHR EOD=GETSTRX       SET X.CHR=NEXT CHARACTER 
          CALL   CHKSEPW           WARN IF CHR IS ILLEGAL W/O SPACE 
___       EQ     GETSTRX           GO EXIT WITH OP
          TITLE  SIGN -  FOUND A SIGN 
  
*     FOUND + OR -
 SIGN     LABEL 
          SX.STO /TKNTYPE/OP       SET CLATYPE IN CASE IT IS AN OPERATOR
          SA.STO CLATYPE
          BX.STO X.CHR
          SA.STO CLAVALU E
          SX.STO 1                 NOTE SIGN
          SA.STO SIGNSW 
          PUTCHR                   SAVE SIGN
___       GETCHR EOD=GETSTRX       SET X.CHR = NEXT CHARACTER 
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.SIGN 
          UX.LOD X.LOD,B.TMP
_____     JP     SIGN+B.TMP 
SIGNCDP   SPACE  4
*     SAVED <SIGN>
*     SET OP
*     FOUND . OR ,
 SIGNCDP  LABEL 
          SA.LOD DECPOIN T
          AX.LOD 9*6
          MX.MSK -6                77777777777777777700B
          BX.LOD -X.MSK*X.LOD      STRIP BLANKS FROM DECIMAL POINT
          IX.TMP X.CHR-X.LOD
_____     NZ     X.TMP,SIGNWRN     IF NOT DECIMAL-POINT CHR, GO WARN
___       GETCHR EOD=GETSTRX       GET CHR FOLLOWING DEC. PT. CHARACTER 
          SA.LOD CHRTBL+X.CHR 
          LX.LOD S.DIGIT
          IFTHEN X.LOD<0           IF DIGIT 
            SB.CNT 18                ALLOW 18 DIGITS AFTER DECIMAL-POINT
            SX.STO 1 TRUE 
            SA.STO SIGNSW 
_____       EQ     NUMCDP1           GO PROCESS NLIT
            ENDIF.
  
*     SAVED <SIGN>
*     SET OP
*     FOUND DECIMAL-POINT CHARACTER FOLLOWED BY NON-DIGIT 
          SA.CHR A.CHR-1           RETREAT TO THE DECIMAL POINT CHR 
_____     EQ     SIGNWRN           GO WARN
SIGNILL   SPACE  4,8
*     SAVED <SIGN>
*     SET OP
*     FOUND NON-COBOL CHARACTER 
 SIGNILL  LABEL 
          * (THIS CHARACTER MAY ONLY BE USED IN A NON-NUMERIC LITERAL,
          *  IN A COMMENT-ENTRY OR ON A COMMENT LINE. 
          *  A SPACE IS ASSUMED.) 
          DIAGNOSE F,1002,LINENO,COLNO
          GETCHR EOD=GETSTRX
___       EQ     GETSTRX           GO EXIT WITH OP
SIGNNUM   SPACE  4,4
*     SAVED <SIGN>
*     SET OP
*     FOUND DIGIT 
 SIGNNUM  EQU    NUM1 
 SIGNOK   EQU    GETSTRX           GO EXIT WITH OP
SIGNCQT   SPACE  4,4
*     SAVED <SIGN>
*     SET OP
*     FOUND " OR '
 SIGNCQT  EQU    NUMCQT 
SIGNWRN   SPACE  4,8
*     SAVED <SIGN>
*     SET OP
*     FOUND CHARACTER NEEDING A WARNING 
 SIGNWRN  LABEL 
          * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
          *  AN INTERVENING SPACE IS ASSUMED.)
          DIAGNOSE W,1001,LINENO,COLNO
___       EQ     GETSTRX           GO EXIT WITH OP
          TITLE  STAR -  FOUND AN ASTERISK (STAR) 
  
*     SAVED NOTHING 
*     FOUND ASTERISK (STAR) 
  
 STAR     LABEL 
          PUTCHR                   SAVE * 
          SX.STO /TKNTYPE/OP       MUST BE OPERATOR 
          SA.STO CLATYPE
_____     GETCHR EOD=STAR1         SET X.CHR = NEXT CHARACTER 
  
          SB.TMP X.CHR-1R*
          IFTHEN B.TMP"0           IF (ASTERISK, NON-ASTERISK)
            SX.STO 1R*               OPERATOR IS *
            SA.STO CLAVALU E
            SB.TMP X.CHR-1R 
            IFTHEN B.TMP"0           IF NOT (ASTERISK, SPACE), ERROR
              * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
              *  AN INTERVENING SPACE IS ASSUMED.)
              DIAGNOSE T,1001,LINENO,COLNO
              ENDIF.
          ELSE-                    IF (ASTERISK, ASTERISK)
            PUTCHR                   SAVE THE SECOND *
            SX.STO EXPCHAR           OPERATOR = EXP 
            SA.STO CLAVALU E
___         GETCHR EOD=GETSTRX       SET X.CHR = NEXT CHARACTER 
            SB.TMP X.CHR-1R 
            IFTHEN B.TMP"0           IF NOT (ASTERISK, ASTERISK, SPACE) 
              * (THIS CHARACTER MAY NOT FOLLOW THE PRECEDING CHARACTER. 
              *  AN INTERVENING SPACE IS ASSUMED. 
              DIAGNOSE T,1001,LINENO,COLNO
              ENDIF.
            ENDIF.
  
___       EQ     GETSTRX           GO EXIT WITH OP OF * OR EXP
  
  
*     FOUND *<END-OF-DATA>
 STAR1    LABEL 
          SX.STO 1R*               OPERATOR IS *
          SA.STO CLAVALU E
___       EQ     GETSTRX           GO EXIT WITH OP OF * 
          TITLE  CHRTBL -  MACRO DEFINITIONS
 FIELD    MACRO  NAME 
 CHRNUM   SET    00B
 FIELD    MICRO  1,, NAME 
 FIELD    ENDM
  
  
          MACRO  CHR,NUM,VALUE
          IFC    NE, NUM  ,1
          ERRNZ  NUM_B-CHRNUM   CHR IS OUT OF SEQUENCE     "SEQUENCE" 
 NN       OCTMIC CHRNUM,2 
          IFC    NE, VALUE  ,6
*  THE FOLLOWING DISTINCTION IS NEEDED BECAUSE OF AN ANOMALY IN THE 
*  UNPACK INSTRUCTION-  2000B+N YIELDS +(N) WHILE 2000B-N YIELDS -(N-1) 
          IF     DEF,/MAYBENEG/"FIELD",3
          IFLT   VALUE,"FIELD",2
 "FIELD""NN"  MICRO  1,, VALUE-1
          SKIP   1
 "FIELD""NN"  MICRO  1,, VALUE
          SKIP   1
 "FIELD""NN"  MICMIC DF"FIELD"
 CHRNUM   SET    CHRNUM+1 
 CHR      ENDM
          NOREF  CHRNUM 
  
  
  
          MACRO  MICMIC,A,B 
 A        MICRO  1,, "B"
 MICMIC   ENDM
  
  
 DFAW     MICRO  1,,
 DFDIGIT  MICRO  1,,
 DFFIRST  MICRO  1,, BAD
 DFLEAD   MICRO  1,,
 DFNOBLNK MICRO  1,,
 DFNUM    MICRO  1,, BAD
 DFSIGN   MICRO  1,, BAD
  
          QUAL   MAYBENEG 
 NUM      EQU    1
 SIGN     EQU    1
          QUAL   *
  
 BAD      BSS    0
          $BEGIN
          EQ     400000B+*
          $END
          TITLE  CHRTBL -  AW 
  
*     FLAG CHARACTERS LEGAL IN AW 
  
 LEGAL    EQU    1
          FIELD  AW 
00        CHR                      :  
 01-32    DUP    26,1              A-Z
          CHR    LEGAL
 33-44    DUP    10,1              0-9
          CHR    LEGAL
 45       CHR                      +
 46       CHR    LEGAL             -
 47-77    DUP    31B,1             *-;
          CHR 
          TITLE  CHRTBL -  DIGIT
  
*     FLAG DIGITS 
  
 LEGAL    EQU    1
          FIELD  DIGIT
 00       CHR                      :  
 01-32    DUP    26,1              A-Z
          CHR 
 33-44    DUP    10,1              0-9
          CHR    LEGAL
 45-77    DUP    33B,1             +-;
          CHR 
          TITLE  CHRTBL -  FIRST
  
*     JUMP TABLE FOR FIRST CHARACTER OF TOKEN 
  
          FIELD  FIRST
 C63A     IFEQ   OP.CH63,OP.YES 
 00       CHR                      NOT AVAIL ON 63 CHAR SYSTEM
 C63A     ELSE
 00       CHR    SGL         :  
 C63A     ENDIF 
 01-32    DUP    26,1              A-Z
          CHR    ALPHA
 33-44    DUP    10,1              0-9
          CHR    NUM
 45       CHR    SIGN              +
 46       CHR    SIGN              -
 47       CHR    STAR              *
 50       CHR    SGL               /
 51       CHR    LPAREN            (
 52       CHR    RPAREN            )
 53       CHR                      $
 54       CHR    CTD               =
 55       CHR 
 56       CHR    CDP               ,
 57       CHR    CDP               .
 60       CHR                      #
 61       CHR                      [
 62       CHR                      ]
 C63B     IFEQ   OP.CH63,OP.YES 
 63       CHR    SGL               :  
 C63B     ELSE
 63       CHR                      %
 C63B     ENDIF 
 64       CHR    CQT               "
 65       CHR                      _
 66       CHR                      !
 67       CHR                      &
 70       CHR    CQT               '
 71       CHR                      ?
 72       CHR    SGL               <
 73       CHR    SGL               >
 74       CHR                      @
 75       CHR                      \
 76       CHR                      ^
 77       CHR    PUNC              ;
          TITLE  CHRTBL -  LEAD 
  
*     FLAG CHARACTERS THAT CAN START A TOKEN
  
 START    EQU    1
          FIELD  LEAD 
 C63C     IFEQ   OP.CH63,OP.YES 
 00       CHR                      NOT AVAIL ON 63 CHAR SYSTEM
 C63C     ELSE
 00       CHR    START       :  
 C63C     ENDIF 
 01-32    DUP    26,1              A-Z
          CHR    START
 33-44    DUP    10,1              0-9
          CHR    START
 45       CHR    START             +
 46       CHR    START             -
 47       CHR    START             *
 50       CHR    START             /
 51       CHR    START             (
 52       CHR    START             )
 53       CHR                      $
 54       CHR    START             =
 55       CHR 
 56       CHR    START             ,
 57       CHR    START             .
 60       CHR                      #
 61       CHR                      [
 62       CHR                      ]
 C63D     IFEQ   OP.CH63,OP.YES 
 63       CHR    START             :  
 C63D     ELSE
 63       CHR                      %
 C63D     ENDIF 
 64       CHR    START             "
 65       CHR                      _
 66       CHR                      !
 67       CHR                      &
 70       CHR    START             '
 71       CHR                      ?
 72       CHR    START             <
 73       CHR    START             >
 74       CHR                      @
 75       CHR                      \
 76       CHR                      ^
 77       CHR    START             ;
          TITLE  CHRTBL - NOBLNK
  
*     FLAG CHARACTERS THAT CAN START A TOKEN WITHOUT A PRECEDING SPACE
  
          FIELD  NOBLNK 
 C63E     IFEQ   OP.CH63,OP.YES 
 00       CHR                      NOT AVAIL ON 63 CHAR SYSTEM
 C63E     ELSE
 00       CHR    1           :  
 C63E     ENDIF 
 01-32    DUP    26,1              A-Z
          CHR 
 33-44    DUP    10,1              0-9
          CHR 
 45       CHR                      +
 46       CHR                      -
 47       CHR                      *
 50       CHR                      /
 51       CHR                      (
 52       CHR    1                 )
 53       CHR                      $
 54       CHR    1                 =
 55       CHR    1                 BLANK
 56       CHR    1                 ,
 57       CHR    1                 .
 60       CHR                      #
 61       CHR                      [
 62       CHR                      ]
 C63F     IFEQ   OP.CH63,OP.YES 
 63       CHR    1                 :  
 C63F     ELSE
 63       CHR                      %
 C63F     ENDIF 
 64       CHR                      "
 65       CHR                      _
 66       CHR                      !
 67       CHR                      &
 70       CHR                      '
 71       CHR                      ?
 72       CHR                      <
 73       CHR                      >
 74       CHR                      @
 75       CHR                      \
 76       CHR                      ^
 77       CHR    1                 ;
          TITLE  CHRTBL -  NUM
  
*     JUMP TABLE FOR CHARACTERS FOLLOWING DIGITS STRING 
  
          FIELD  NUM
 C63G     IFEQ   OP.CH63,OP.YES 
 00       CHR    NUMILL            NOT AVAIL ON 63 CHAR SYSTEM
 C63G     ELSE
 00       CHR    NUMOK       :  
 C63G     ENDIF 
 01-32    DUP    26,1              A-Z
          CHR    NUMALP 
 33-44    DUP    10,1              0-9
          CHR 
 45       CHR    NUMWRN            +
 46       CHR    NUMHYPH           -
 47       CHR    NUMWRN            *
 50       CHR    NUMWRN            /
 51       CHR    NUMFTL            (
 52       CHR    NUMOK             )
 53       CHR    NUMILL            $
 54       CHR    NUMCTD            =
 55       CHR    NUMOK             BLANK
 56       CHR    NUMCDP            ,
 57       CHR    NUMCDP            .
 60       CHR    NUMILL            #
 61       CHR    NUMILL            '
 62       CHR    NUMILL            ]
 C63H     IFEQ   OP.CH63,OP.YES 
 63       CHR    NUMOK             :  
 C63H     ELSE
 63       CHR    NUMILL            %
 C63H     ENDIF 
 64       CHR    NUMCQT            "
 65       CHR    NUMILL            _
 66       CHR    NUMILL            !
 67       CHR    NUMILL            &
 70       CHR    NUMCQT            '
 71       CHR    NUMILL            ?
 72       CHR    NUMWRN            <
 73       CHR    NUMWRN            >
 74       CHR    NUMILL            @
 75       CHR    NUMILL            \
 76       CHR    NUMILL            ^
 77       CHR    NUMOK             ;
          TITLE  CHRTBL -  SIGN 
  
*     JUMP TABLE FOR CHARACTERS FOLLOWING + OR -
  
          FIELD  SIGN 
 00       CHR    SIGNILL           :  
 01-32    DUP    26,1              A-Z
          CHR    SIGNWRN
 33-44    DUP    10,1              0-9
          CHR    SIGNNUM
 45       CHR    SIGNWRN           +
 46       CHR    SIGNWRN           -
 47       CHR    SIGNWRN           *
 50       CHR    SIGNWRN           /
 51       CHR    SIGNWRN           (
 52       CHR    SIGNWRN           )
 53       CHR    SIGNILL           $
 54       CHR    SIGNWRN           =
 55       CHR    SIGNOK            BLANK
 56       CHR    SIGNCDP           ,
 57       CHR    SIGNCDP           .
 60       CHR    SIGNILL           #
 61       CHR    SIGNILL           [
 62       CHR    SIGNILL           ]
 63       CHR    SIGNILL           %
 64       CHR    SIGNCQT           "
 65       CHR    SIGNILL           _
 66       CHR    SIGNILL           !
 67       CHR    SIGNILL           &
 70       CHR    SIGNCQT           '
 71       CHR    SIGNILL           ?
 72       CHR    SIGNWRN           <
 73       CHR    SIGNWRN           >
 74       CHR    SIGNILL           @
 75       CHR    SIGNILL           \
 76       CHR    SIGNILL           ^
 77       CHR    SIGNWRN           ;
          TITLE  CHRTBL 
 S.FIRST  EQU    0
 S.SIGN   EQU    12 
 S.NUM    EQU    24 
 S.LEAD   EQU    36 
 S.AW     EQU    37 
 S.DIGIT  EQU    38 
 S.NOBLNK EQU    39 
  
 A        EQU    2000B-GETSTR 
 B        EQU    2000B-SIGN 
 C        EQU    2000B-NUM
  
          LIST   G
 CHRTBL   BSS    0
          ECHO  1,NN=(00,01,02,03,04,05,06,07,10,11,12,13,14,15,16,17,20
,,21,22,23,24,25,26,27,30,31,32,33,34,35,36,37,40,41,42,43,44,45,46,47,5
,0,51,52,53,54,55,56,57,60,61,62,63,64,65,66,67,70,71,72,73,74,75,76,77)
+         VFD    12/A+"FIRST_NN",12/B+"SIGN_NN",12/C+"NUM_NN",1/"LEAD_NN
,",1/"AW_NN",1/"DIGIT_NN",1/"NOBLNK_NN",*P/-0 
          LIST   *
          TITLE  STATUS LIST TKNTYPE
  
*CALL STATUS
  
          QUAL   TKNTYPE
  
          STATUS  TKNTYPE 
*CALL TKNTYPE 
  
          QUAL   *
          TITLE  DATA 
  
*     DATA
  
          EXT    ACHR              VALUE OF A.CHR BETWEEN CALLS 
  
 A=CHR    BSS    1                 VALUE OF A.CHR WHILE CALLING 
  
 B=CNT    BSS    1                 VALUE OF B.CNT WHILE CALLING 
  
 B=SAL    BSS    1                 VALUE OF B.SAL 
  
 B=SCT    BSS    1                 VALUE OF B.SCT WHILE CALLING 
  
 A=SAV    BSS    1                 VALUE OF A.SAV WHILE CALLING 
  
          EXT    CLALCOL UMN       COLUMN NUMBER OF LAST CHR IN TOKEN 
  
          EXT    CLALINE
  
          EXT    CLALVLN           V.L.N. OF LAST CHR IN TOKEN
  
          EXT    CLAMOD 
  
          EXT    CLACOLU MN 
  
          EXT    CLATYPE           TYPE OF CLASSIFIED TOKEN 
  
          EXT    CLAVLN            VIRTUAL LINE NO. OF FIRST CHARACTER
          EXT    CLACOMM ENT
  
          ENTRY  COLNO
 COLNO    BSS    1                 CURRENT COLUMN NUMBER SET BY *SETPOS*
  
          EXT    CPYLINE
  
 DIGIT    BSS    1                 SCRATCH
  
          EXT    DECPOIN T         TRUE DECIMAL-POINT CHARACTER 
  
          EXT    EXCEPT            WHICH GETSTR EXCEPTIONAL SITUATION - 
                                     0 = NORMAL 
                                     2 = END-OF-DATA
                                     3 = NUMALP3 IN GETSTR
  
          EXT    ENDCHRS           0 = LAST LINE NOT PRINTED YET
*                                  1 = LAST LINE HAS BEEN PRINTED 
  
 TOOLONG  BSS    1                 TRUE IFF MUCH TOO LONG TOKEN 
  
 EXPCHAR  EQU    5           E
  
          EXT    LINENO            USER LINE NO. OF CURRENT LINE
          EXT    NEWCOL7           VALUE COL 7 - NEXT CARD
  
  
          EXT    READLIB           TRUE IFF READING FROM LIBRARY
  
          EXT    QUOTE             TRUE DELIMITER FOR NON-NUMERIC LITS. 
  
          EXT    SAREALE NGTH 
  
          EXT    SRCLINE
  
          EXT    CLAVALU E
  
          EXT    STRINGA RRAY 
 SAREA    EQU    STRINGA           CHARACTERS COMPRISING TOKEN
  
          EXT    SIGNSW            TRUE IFF TOKEN IS SIGNED 
  
          EXT    CURRVLN           VIRTUAL LINE NUMBER OF CURRENT LINE
  
          EXT    ALLOWLR GILIT
  
          EXT    ILITISP NREF 
  
 X=SAV    BSS    1                 VALUE OF X.SAV WHILE CALLING 
          SPACE  4
          END 
