*DECK GETPIC
          IDENT  GETPIC 
          TITLE  GETPIC -  GET PICTURE CHARACTER-STRING 
          COMMENT  GET PICTURE CHARACTER-STRING 
  
*CALL STRUCT
  
          SPACE  4
**        GETPIC -  GET PICTURE CHARACTER-STRING
* 
*     CALLING SEQUENCE- 
*         GETPIC;                  (FROM SYMPL) 
* 
*     GIVEN-
*         ACHR = ADDRESS OF CURRENT CHARACTER.
* 
*     DOES- 
*         CLATYPE = TKNTYPE"PIC". 
*         SAREA = PICTURE CHARACTER-STRING, LEFT-JUSTIFIED, BLANK-FILLED
*         SAREALENGTH = NUMBER OF CHARACTERS IN SAREA.
*         CLALINE = LINE NUMBER OF FIRST CHARACTER OF CHARACTER-STRING. 
*         CLAVLN = VIRTUAL LINE NUMBER OF LINE WITH FIRST CHAR. 
*         CLACOLUMN = COLUMN NUMBER OF FIRST CHARACTER OF STRING. 
*         CLALVLN = VIRTUAL LINE NUMBER OF LINE WITH LAST CHAR. 
*         CLALCOLUMN = COLUMN NUMBER OF LAST CHARACTER OF STRING. 
*         ACHR IS UPDATED TO THE CHARACTER FOLLOWING THE STRING.
*         IF AN IMMEDIATE END-OF-DATA IS ENCOUNTERED, 
*           A DIAGNOSTIC IS ISSUED, AND 
*           A NULL PICTURE CHARACTER STRING IS PRODUCED.
* 
*     NOTE- 
*         CORRECTLY SETTING CLALVLN IS TRICKY BECAUSE THE LAST
*         CHARACTER PICKED UP MAY NOT BE THE LAST CHARACTER 
*         OF THE PICTURE STRING;  IF IT IS PUNCTUATION (. ; ,)
*         IT WILL BE DELETED.  IN THIS CASE THE V.L.N. OF THE 
*         PREVIOUS CHARACTER MUST BE USED.
*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
          BX.SAV X.SAV-X.CHR
          SB.SCT B.SCT-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
          EJECT 
  
*     BEGIN EXECUTION 
  
 GETPIC   SUBR
  
*     CLATYPE IS TKNTYPE"PIC" 
  
          SX.STO /TKNTYPE/PIC 
          SA.STO CLATYPE
  
*     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+1
          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
  
*     SKIP LEADING BLANKS 
  
1         LOOP1 
            SB.TMP X.CHR-1R 
_____       NZ     B.TMP,GETPIC1     IF NON-BLANK FOUND 
_____       GETCHR EOD=GETPICX
_           EQ     LOOP1
  
*     SET CLALINE, CLACOLUMN AND CLAVLN FOR FIRST CHARACTER OF TOKEN
  
 GETPIC1  LABEL 
          SA.LOD LINENO 
          BX.STO X.LOD
          SA.STO CLALINE
          SA.LOD READLIB           1 (TRUE) IFF READING FROM LIBRARY
          IFTHEN X.LOD"0           IF READING FROM COPY LIBRARY 
            SB.TMP CPYLINE-7         A.CHR IS IN CPYLINE
          ELSE-                    IF READING FROM SOURCE INPUT 
            SB.TMP SRCLINE-7         A.CHR IS IN SRCLINE
            ENDIF.
          SX.STO A.CHR-B.TMP       COLUMN NUMBER
          SA.STO CLACOLU MN 
          EXT    CLAVALU E
  
          SA.LOD CURRVLN
          BX.STO X.LOD
          SA.STO CLAVLN 
          SA.LOD PTPOSS 
          IFTHEN X.LOD"0     COPY REPLACING BEING PROCESSED 
            SB.TMP X.CHR-1R=       PSUEDO-TEXT DELIMITERS POSSIBLE
            ZR     B.TMP,GETPIC6
            ENDIF.
  
*     COLLECT PICTURE CHARACTERS
  
          SB.CNT 30+1              INCLUDE TRAILING PUNCTUATION 
1         LOOP1 
            SA.LOD CURRVLN
            BX.STO X.LOD
            SA.STO LASTVLN
            PUTCHR                   SAVE X.CHR IN SAREA
_____       GETCHR EOD=GETPIC4       SET X.CHR = NEXT CHARACTER 
            SB.TMP X.CHR-1R 
_____       ZR     B.TMP,GETPIC4     IF END OF PICTURE STRING 
            SB.TMP X.CHR-1R=         IF START OF PSEUDO-TEXT DELIMITER
            ZR     B.TMP,GETPIC4   THEN END OF PICTURE STRING 
            SB.CNT B.CNT-1           DECREMENT MAX. NUMBER OF CHARACTERS
_           NZ     B.CNT,LOOP1       IF STILL LEGAL TO COLLECT CHRS.
  
*     SAVED 31 CHARACTERS 
*     FOUND NON-BLANK CHARACTER 
  
          MX.SAV 0           DELETE 31ST CHARACTER
          SB.SCT 9
* (THIS PICTURE CHARACTER-STRING HAS MORE THAN 30 CHARACTERS. 
*  ONLY THE LEFT 30 CHARACTERS ARE USED.) 
          DIAGNOSE F,1041,CLALINE,CLACOLUMN 
  
1         LOOP1              SKIP REMAINING NON-BLANKS AND NON-=
_____       GETCHR EOD=GETPIC2
            SB.TMP X.CHR-1R 
            ZR     X.TMP,GETPIC3   IF =, GO RETREAT 
            SB.TMP X.CHR-1R 
_           NZ     B.TMP,LOOP1       IF STILL NON-BLANK, LOOP 
  
*     SAVED 31 CHARACTERS 
*     SKIPPED AT LEAST 1 MORE NON-BLANK 
*     FOUND BLANK 
 GETPIC2  LABEL                    (HERE IF EOD SKIPPING NON-BLANKS)
          SA.LOD A.CHR-1     EXAMINE LAST NON-BLANK 
          SB.TMP X.LOD-1R,
          ZR     B.TMP,GETPIC3     IF PUNCTUATION, GO RETREAT 
          SB.TMP X.LOD-1R.
          ZR     B.TMP,GETPIC3     IF PUNCTUATION, GO RETREAT 
          SB.TMP X.LOD-1R;
          ZR     B.TMP,GETPIC3     IF PUNCTUATION, GO RETREAT 
  
*     SAVED 30 CHARACTERS   (THE 31ST WAS DELETED)
*     SKIPPED REMAINING NON-BLANK 
*     LAST NON-BLANK WAS NOT PUNCTUATION
_____     EQ     GETPICX           GO EXIT FROM GETPIC
  
  
*     SAVED 30 CHARACTERS   (31ST CHARACTER WAS DELETED)
*     SKIPPED REMAINING NON-BLANKS
*     LAST NON-BLANK WAS A PUNCTUATION OR = CHARACTER 
 GETPIC3  LABEL 
          SA.CHR A.CHR-1           RETREAT BEFORE PUNCTUATION 
_____     EQ     GETPICX           GO EXIT FROM GETPIC
  
  
*     SAVED 1-31 CHARACTERS 
*     FOUND BLANK OR END-OF-DATA
 GETPIC4  LABEL 
          SA.LOD A.CHR-1           EXAMINE LAST CHARACTER IN STRING 
          SB.TMP X.LOD-1R.
_____     ZR     B.TMP,GETPIC5     IF PUNCTUATION, DELETE AND RETREAT 
          SB.TMP X.LOD-1R,
_____     ZR     B.TMP,GETPIC5     IF PUNCTUATION, DELETE AND RETREAT 
          SB.TMP X.LOD-1R;
_____     ZR     B.TMP,GETPIC5     IF PUNCTUATION, DELETE AND RETREAT 
  
*     SAVED 1-31 CHARACTERS 
*     LAST CHARACTER WAS NOT PUNCTUATION
*     FOUND BLANK OR END-OF-DATA
          SA.LOD CURRVLN
          BX.STO X.LOD
          SA.STO CLALVLN
_____     NZ     B.CNT,GETPICX     IF SAVED 1-30 CHARACTERS 
  
* (THIS PICTURE CHARACTER-STRING HAS MORE THAN 30 CHARACTERS. 
*  ONLY THE LEFT 30 CHARACTERS ARE USED.) 
          DIAGNOSE F,1041,CLALINE,CLACOLUMN 
  
*     SAVED 31 CHARACTERS 
*  OR 
*     SAVED 1-31 CHARS AND LAST CHAR WAS PUNCTUATION OR = 
 GETPIC5  LABEL                    (HERE IF LAST WAS PUNCTUATION) 
          SA.LOD LASTVLN
          BX.STO X.LOD
          SA.STO CLALVLN
          SB.TMP 9
          IFTHEN B.SCT=B.TMP       IF JUST STORED FULL WORD 
            SA.LOD A.SAV-B..1        RESET A.SAV
            BX.SAV X.LOD
            SA.SAV A.SAV-B..1 
            SA.LOD A.LOD+B..1        LOAD LAST-STORED WORD
            MX.MSK 6
            AX.LOD 6
            BX.SAV -X.MSK*X.LOD      RESET X.SAV
            SB.SCT B..0              RESET B.SCT
          ELSE-                    IF LAST CHARACTER IS IN ONLY X.SAV 
            AX.SAV 6                 THROW AWAY LAST CHARACTER
            SB.SCT B.SCT+B..1        NOTE ONE LESS CHR IN X.SAV 
            ENDIF.
          SA.CHR A.CHR-1           LEAVE PUNC AS CURRENT CHR
          EQ     GETPICX           GO EXIT FROM GETPIC
  
  
*     FOUND = SEE IF WE HAVE A PSEUDO-TEXT DELIMITER
*     CLASSIFY TWO CONTIGUOUS = AS PSEUDO-TEXT DELIMITER ONLY IF
*         PROCESSING COPY REPLACING PSEUDO-TEXT 
 GETPIC6  LABEL 
          GETCHR EOD=GETPIC4
          SB.TMP X.CHR-1R=
          IFTHEN B.TMP"0     (IF(=,NON-=))
            SA.CHR A.CHR-1
            EQ     GETPIC4
            ENDIF.
  
*     FOUND ==
          PUTCHR
          PUTCHR
          SX.STO X.CHR
          SA.STO CLAVALU E
          SX.STO /TKNTYPE/PTDELIM 
          SA.STO CLATYPE
          GETCHR EOD=GETPICX
*     FALL THRU TO GETPICX
  
  
*     SAVE REGISTERS AND EXIT 
 GETPICX  LABEL                    (HERE WHEN TOKEN SET UP) 
                                   SAREALENGTH = 10*NWORDS + 9 - B.SCT
          SB.TMP SAREA-1
          SX.STO A.SAV-B.TMP          NWORDS
          IX.TMP X.STO+X.STO        2*NWORDS
          LX.STO 3                  8*NWORDS
          IX.STO X.STO+X.TMP       10*NWORDS
          SX.STO X.STO+9           10*NWORDS + 9
          SX.TMP B.SCT
          IX.STO X.STO-X.TMP       10*NWORDS + 9 - B.SCT
          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 
          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
          TITLE  STATUS LIST TKNTYPE
  
*CALL STATUS
  
          QUAL   TKNTYPE
  
          STATUS  TKNTYPE 
*CALL TKNTYPE 
  
          QUAL   *
  
          TITLE  DATA 
  
*     DATA
  
          EXT    ACHR              VALUE OF A.CHR BETWEEN CALLS 
  
          EXT    CLATYPE           TYPE OF TOKEN
  
          EXT    CLALINE
  
          EXT    CLALCOL UMN
  
          EXT    CLALVLN
  
          EXT    CLAMOD 
  
          EXT    CLACOLU MN 
  
          EXT    CLAVLN            VIRTUAL LINE NO. OF FIRST CHARACTER
  
          EXT    PTPOSS      TRUE ONLY DURING COPY REPLACING
          EXT    CPYLINE           FIRST UNPACKED CHR FROM COPY LIBRARY 
  
          EXT    CURRVLN           VIRTUAL LINE NO. OF CURRENT LINE 
  
 LASTVLN  BSS    1
  
          EXT    LINENO 
  
          EXT    READLIB           1 (TRUE) IFF READING FROM CPY LIBRARY
  
          EXT    STRINGA REA
 SAREA    EQU    STRINGA           CHARACTERS COMPRISING TOKEN (26 WORDS
  
          EXT    SAREALE NGTH      NUMBER OF CHARACTERS IN SAREA
  
          EXT    SIGNSW 
  
          EXT    SRCLINE           FIRST UNPACKED CHR FROM SOURCE INPUT 
  
  
          END 
