Trailing-Edge
-
PDP-10 Archives
-
BB-Z759A-SM
-
cobol-source/pscan.mac
There are 21 other files named pscan.mac in the archive. Click here to see a list.
; UPD ID= 756 on 1/14/83 at 9:30 AM by NIXON
TITLE PSCAN FOR COBOL V13
SUBTTL COBOL PICTURE SCANNER AL BLACKINGTON/CAM
SEARCH COPYRT
SALL
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
COPYRIGHT (C) 1974, 1983, 1984 BY DIGITAL EQUIPMENT CORPORATION
SEARCH P
%%P==:%%P
TWOSEG
.COPYRIGHT ;Put standard copyright statement in REL file
RELOC 400000
SALL
;EDITS
;NAME DATE COMMENTS
;DMN 1-Apr-82 [1347] Eliminate warning for PIC +,999 or -,999 caused by edit 1312.
;WTK 29-Jul-81 [1312] Warning for +,+++ or -,---
;DMN 25-Mar-81 [1124] Make PIC S(n) illegal.
;DMN 29-MAY-80 [1023] BACKUP TO PERIOD IN COPY REPLACING TEST.
; 30-JAN-76 [404] FIX COUNT OF ALLOWABLE CHARS IN EDITTED PICTURE
; 9-DEC-76 [310] RE-INSERTED FIX ERROR CHECKING OF PIC CLAUSES.
;DBT 4/8/75 - DETECT PIC +$++++..... AS ILLEGAL
; - CHANGE ALL 9'S IN ALPHANUMERIC EDITED PICTURES
; INTO X'S
;DBT 4/14/75 - DETECT ZZZZ AS WELL AS ++++ AS BEING
; BLANK WHEN ZERO
; - DETECT NON LEFT JUSTIFIED SIGN INSERT AS ILLEGAL
;DBT 6/6/75 - ALLOW +PPP999 AND 999PPPCR
;********************
;EDIT 211 ALLOW LC LETTERS IN A PICTURE CLAUSE
;A PICTURE IS CONVERTED INTO A MASK.
;INTERNAL SIZE, EXTERNAL SIZE AND DECIMAL LOCATIONS ARE CALCULATED.
;THE FEDIT, FSIGN, FBWZ AND CLASS FLAGS ARE SET IN "SW" AS APPROPRIATE.
;CONTENTS OF ALL OTHER ACCUMULATORS, EXCEPT LN & CP, ARE SAVED.
;LN & CP ARE SET TO THE POSTION OF THE FIRST CHARACTER OF THE WORD.
ENTRY PSCAN
EXTERNAL GETKAR, GETCH, FATAL, FATALW
;THE VALIDITY OF THE MASK IS DETERMINED BY USING A
; TRUTH TABLE. WHEN A CHARACTER IS PICKED UP, A
; BIT IS SET IN ACCUMULATOR "TC" TO REPRESENT
; ONE OF THE CONDITIONS SHOWN BELOW; AND ACCUMULATOR
; "TA" IS SET TO POINT TO THE APPROPRIATE ENTRY IN
; THE TRUTH TABLE. IF THAT ENTRY CONTAINS ANY BITS
; MATCHING THOSE IN "PC", THE CHARACTER IS INVALID.
;"TC" IS THEN ORED INTO "PC".
;FLAGS FOR ACCUMULATOR "PC"
; 0 + OR - INSERT IS NOT LEADING ;18 P BEFORE 9,POINT
; 1 + FLOAT AFTER 9, POINT ;19 Z BEFORE 9, POINT
; 2 + INSERT AFTER 9, POINT ;20 * BEFORE 9, POINT
; 3 - FLOAT AFTER 9, POINT ;21 $ FLOAT BEFORE 9, POINT
; 4 - INSERT AFTER 9, POINT ;22 $ INSERT BEFORE 9, POINT
; 5 P AFTER POINT ;23 + FLOAT BEFORE 9, POINT
; 6 Z AFTER POINT ;24 + INSERT BEFORE 9, POINT
; 7 * AFTER POINT ;25 - FLOAT BEFORE 9, POINT
; 8 $ FLOAT AFTER POINT ;26 - INSERT BEFORE 9, POINT
; 9 $ INSERT AFTER POINT ;27 9
;10 + FLOAT BEFORE 9, AFTER POINT ;28 V
;11 + INSERT BEFORE 9, AFTER POINT ;29 S
;12 - FLOAT BEFORE 9, AFTER POINT ;30 A,X
;13 - INSERT BEFORE 9, AFTER POINT ;31 CR,DB
;14 + FLOAT AFTER 9, BEFORE POINT ;32 DECIMAL POINT
;15 + INSERT AFTER 9, BEFORE POINT ;33 COMMA
;16 - FLOAT AFTER 9, BEFORE POINT ;34 0
;17 - INSERT AFTER 9, BEFORE POINT ;35 B
;NON-STANDARD ACCUMULATORS USED
PC=3 ;FLAGS REPRESENTING CHARACTERS ALREADY SEEN
PR=5 ;CONTAINS REPEAT COUNTER
MP=6 ;BYTE POINTER TO MASK WORDS
SP=7 ;SAVE MP WHEN FIRST FLOATER SEEN
PICCNT=10 ;COUNT NO. CHARACTERS IN PICTURE - 30 MAX
ST=11 ;SAVE POINTER TO PICT2 TABLE
HI==TA ;HIGHEST ACCUMULATOR SAVED BY THIS ROUTINE
FOFF==FFLOAT!FSIGN!FCLAS1!FEDIT!FBWZ
PSCAN: MOVEM HI,SAVEAC+HI ;SAVE THE ACCUMULATORS
MOVEI HI,SAVEAC
BLT HI,SAVEAC+HI-1
SWOFF FOFF ;TURN OFF FLAGS
SWON FCLAS2; ;TURN ON ALPHABETIC FLAG
MOVE PC,[POINT 7,PICBUF##]
MOVEM PC,PICPTR##
SETZM PICBUF
MOVE PC,[PICBUF,,PICBUF+1]
BLT PC,PICBUF+6
SETZB PC,EXSIZE ;CLEAR COUNTERS
SETZB PR,INSIZE
SETZM DPSIZE
MOVE MP,MSKPTR
SETZM (MP) ;CLEAR SIGN AND FLOAT CHARACTERS, &
MOVEI PICCNT,^D30 ;MAX NUMBER OF CHARACTERS IN PIC SOURCE
;NO CHARACTERS TO REPEAT
SETZM FLOTBZ##
TSWF FREGCH ;[310] PASSED PIC TERMINATOR?
JRST PSCAN1 ;[310] YES-OKAY SO FAR
CAIE CH," " ;[310] DID WE GET HERE VIA BLANK?
JRST PICERL ;[310] NO- THEN WE HAVE NO PICTURE
;SKIP OVER LEADING SPACES
PSCAN1: PUSHJ PP,GETCH ;GET A CHARACTER
TSWF FEOF; ;END OF INPUT?
JRST FINISH ;YES
CAIN CH," " ;NO--SPACE?
JRST PSCAN1 ;YES--SKIP IT
PUSHJ PP,PCONVL ;[211] CONVERT LC-TO UPPER
DMOVEM LN,WORDLN
;CHECK FOR THE WORD "IS"
CAIE CH,"I"
JRST PSCN1B
PUSHJ PP,GETCPY
CAIE CH,"S"
JRST PICERD
PUSHJ PP,GETCPY
CAIE CH," "
JRST PICERD
PSCN1A: PUSHJ PP,GETCH
CAIN CH," "
JRST PSCN1A
PUSHJ PP,PCONVL ;[211] CONVERT LC-TO UPPER
PSCN1B: MOVEM CH,PICSAV ;SAVE CHARACTER
DMOVEM LN,SAVEAC+LN ;SAVE LN,CP
DMOVEM LN,WORDLN
DMOVEM LN,SAVLN1
JRST PSCN2A
;GET A PICTURE CHARACTER
PSCAN2: MOVE CH,PICSAV## ;RESTORE LOOKAHEAD CHARACTER
PUSHJ PP,GETCP0 ;NOTE THAT WE ARE TAKING CHARACTER
CAIE CH," " ;END OF PICTURE?
JRST PSCN2A ;NO
TSWF FREGCH ;IF LOOKAHEAD IS ON (IT SHOULD BE)
IDPB CH,PICPTR ;STORE THE LOOKAHEAD CHAR, IT WILL BE REMOVED LATER
JRST FINISH ;GO TO END OF PIC STRING
PSCN2A: TSWT FEOF; ;END OF FILE?
CAIN CH,";" ;OR IS IT ";"
JRST FINISH ;YES
CAIN CH,"," ;NO--IS IT ","
JRST PSCN2B ;YES
CAIN CH,"=" ;COULD IT BE PSEUDO-TEXT?
JRST PSCAN3 ;YES
CAIE CH,"." ;IS IT A PERIOD?
JRST PICS ;NO
TSWF FRTST ;[1023] ARE WE DOING A REPLACEMENT CHECK?
PUSHJ PP,SVPER ;[1023] YES, SAVE THE CURRENT INPUT BYTE PTR AND BYTE COUNT
;[1023] SO WE CAN BACKUP TO JUST AFTER THE PERIOD
;[1023] INCASE THERE WAS A CR-LF AFTER PERIOD
;IT IS PERIOD OR COMMA--SEE IF LAST CHARACTER
PSCN2B: PUSHJ PP,GETKAR ;LOOK AT NEXT CHARACTER
CAIN CH," " ;IS IT A SPACE?
JRST PSCAN4 ;YES -- DONE
TSWT FEOF; ;NO--END OF FILE?
JRST PICS00
;TERMINATING CHARACTER SEEN
PSCAN4: MOVE CH,PICSAV ;GET CHAR BACK
CAIE CH,"." ;[1023] WAS IT PERIOD?
JRST FINISH ;[1023] NO
SWON FGTPER; ;YES--TELL GETWRD ROUTINE
TSWT FRTST ;[1023] ARE WE DOING A REPLACEMENT CHECK?
JRST FINISH ;[1023] NO
MOVE TE,R4BH0 ;[1023] GET ORIGINAL BLOCK NUMBER
CAMN TE,RPLBLK ;[1023] SAME AS CURRENT?
JRST PSCN4A ;[1023] YES
MOVEM TE,RPLBLK ;[1023] THIS WILL SOON BE CURRENT
IFE TOPS20,<
USETI LIB,(TE) ;[1023] NO, RESET ON OLD BLOCK
IN LIB, ;[1023] AND READ IT IN
PSCN4A: SKIPA TE,R4BH1 ;[1023] OK, GET BYTE PTR
JRST GETLB9## ;[1023] ERROR
>
IFN TOPS20,<
PUSHJ PP,SFPLIB## ;SET FILE POINTER
PUSHJ PP,GETLBA## ;FILL BUFFER
PSCN4A: MOVE TE,R4BH1
>
MOVEM TE,LIBBH+1 ;[1023] RESET IT
MOVE TE,R4BH2 ;[1023]
MOVEM TE,LIBBH+2 ;[1023] SAME FOR COUNT
MOVE CP,R4CPI ;[1023]
MOVEM CP,INPTCP ;[1023]
MOVE CP,R4CPO ;[1023] RESTORE CP
MOVEM CP,SAVECP ;[1023]
MOVE CH,[R4BH0,,L2BH0##] ;[1023] COPY INFO ABOUT PERIOD
BLT CH,L2CPI## ;[1023] TO WHERE INFO ABOUT NEXT SPACE IS STORED
JRST FINISH
PSCAN3: SWON FREGCH ;REGET = ON RETURN
MOVEI CH," " ;FAKE A SPACE
JRST FINISH ;AND GET OUT
;[1023] THIS ROUTINE IS SIMILAR TO SVPKAR IN GETITM
;[1023] IT SAVES THE LOCATION OF THE CHARACTER AFTER THE PERIOD
;[1023] IN CASE THAT IS A FAKE SPACE GENERATED BY A CR-LF
SVPER: MOVE CH,RPLBLK## ;[1023]
MOVEM CH,R4BH0## ;[1023] SAVE CURRENT LIBRARY BLOCK #
MOVE CH,LIBBH##+1 ;[1023] SAVE BYTE PTR AND COUNT
MOVEM CH,R4BH1## ;[1023]
MOVE CH,LIBBH+2 ;[1023]
MOVEM CH,R4BH2## ;[1023]
MOVE CH,SAVECP ;[1023]
ADDI CH,1 ;[1023] WE ACTUALLY WANT THE NEXT CHAR.
MOVEM CH,R4CPO## ;[1023] OUTPUT CHAR. POS.
MOVE CH,INPTCP## ;[1023]
ADDI CH,1 ;[1023]
MOVEM CH,R4CPI## ;[1023] INPUT CHAR. POS.
MOVE CH,PICSAV ;[1023] JUST IN CASE IT MATTERS
POPJ PP, ;[1023]
; WE HAVE A CHARACTER LETS LOOK AHEAD AND SEE IF THERE IS
; A REPEAT FORTH COMMING
PICS: PUSHJ PP,GETKAR ;GET NEXT INPUT CHARACTER
; ENTER HERE IF YOU ALREADY HAVE LOOKAHEAD CHARACTER
PICS00: MOVEI PR,1 ;INITIALIZE REPEAT COUNT
CAIN CH,"(" ;REPEAT???
PUSHJ PP,GETRP ;YES
EXCH CH,PICSAV ;SAVE LOOKAHEAD CHARACTER AND RESTORE CURRENT
;LOOK FOR CHARACTERS WITHOUT SPECIAL CHARACTERISTICS
MOVSI TA,-PICT1S ;SET UP IOWD TO SEARCH PICT1
PICS0: HRRZ TB,PICT1(TA) ;PICK UP CHARACTER FROM TABLE
CAME CH,TB ;DOES IT MATCH INPUT CHARACTER?
AOBJN TA,PICS0 ;NO--LOOP UNTIL ALL OF TABLE SEEN
JUMPG TA,PICS1 ;DID WE FIND ONE?
HLRZ TA,PICT1(TA) ;YES--RESET TA
CAIE CH,"A" ;IS IT "A"
CAIN CH,"B" ; OR "B"?
CAIA ;YES--THIS CHARACTER DOESN'T MAKE IT NON-ALPHABETIC
SWOFF FCLAS2; ;NO--RESET FLAG
CAIE CH,"*" ;IS IT "*"
JRST PICF ;NO
PUSH PP,TA ;SAVE IT
SKIPN TA,CURDAT##
JRST PICS01
LDB TA,DA.BWZ## ;SEE IF BLANK WHEN ZERO SET?
SKIPE TA ;WAS IT?
EWARNW E.701 ;YES
PICS01: POP PP,TA
JRST PICF
;LOOK FOR "$" "," "."
PICS1: SWOFF FCLAS2; ;CANNOT BE ALPHABETIC
MOVNI TA,1
CAMN CH,DOLLR.## ;IS IT A CURRENCY SIGN?
MOVEI TA,16 ;YES
CAMN CH,DCPNT.## ;NO--IS IT DECIMAL POINT?
MOVEI TA,07 ;YES
CAMN CH,COMA.## ;NO--IS IT COMMA?
MOVEI TA,06 ;YES
JUMPG TA,PICF ;WAS IT ANY OF THOSE?
;LOOK FOR "CR" OR "DB"
CAIN CH,"C" ;IS IT "C"?
JRST PICS2 ;YES
CAILE PR,1 ;REPEATING??
JRST PICERF ;YES -- ERROR
CAIE CH,"D" ;NO--IS IT "D"?
JRST PICERA ;NO--ERROR
PUSHJ PP,GETKAR ;YES--GET NEXT CHARACTER
EXCH CH,PICSAV ;SAVE IT AS LOOKAHEAD
PUSHJ PP,GETCP0 ;NOTE THAT WE TOOK LAST CHAR
CAIE CH,"B" ;IS IT "B"?
JRST PICERF ;NO--ERROR
MOVEI TA,11 ;YES--SET TABLE POINTER
JRST PICF
PICS2:
CAILE PR,1 ;REPEATING??
JRST PICERF ;YES -- ERROR
PUSHJ PP,GETKAR ;IT IS "C"--GET NEXT CHARACTER
EXCH CH,PICSAV ;EXCHANGE WITH LOOKAHEAD
PUSHJ PP,GETCP0 ;NOTE THAT WE TOOK IT
CAIE CH,"R" ;IS IT "R"?
JRST PICERF ;NO--ERROR
MOVEI TA,10 ;YES--SET TABLE POINTER
;IT IS A PICTURE CHARACTER
PICF: HLRZ TB,PICT2(TA) ;GET BIT SETTINGS
TRNN TB,%P ;IS IT "P"?
JRST .+3 ;NO
SKIPN INSIZE ;YES--ANY LEADING CHARACTERS?
IORI PC,%V ;NO--"V" IMPLIED
SUBI CH,40 ;CONVERT CHARACTER TO SIXBIT
MOVE TC,TB
TRNE TB,%FLOAT ;CAN IT BE A FLOATER?
PUSHJ PP,FLOAT ;YES--GO SEE IF IT IS
MOVE ST,TA ;SAVE TABLE POINTER
CAIN TA,23 ;CHECK FOR "/"
MOVEI TA,5 ;AND HANDLE AS IF "0"
TRNE TB,%MINUS!%PLUS ;IS THIS A SIGN?
TRNN PC,%9 ;YES--HAS 9 BEEN SEEN?
JRST PICF2 ;NO
LSH TC,11 ;YES--SHIFT BIT
ADDI TA,11 ;ADD TO TABLE POINTER
PICF2: TRNE TB,%SPEC. ;IS THIS SPECIAL AFTER POINT?
TRNN PC,%.!%V ;YES--HAS POINT BEEN SEEN?
JRST PICF3 ;NO
LSH TC,15 ;YES--SHIFT BIT
ADDI TA,15 ;ADD TO TABLE POINTER
PICF3: TDNE PC,PICT3(TA) ;IS CHARACTER LEGAL HERE?
PUSHJ PP,PICERB ;NO--ERROR
;IT IS A LEGAL CHARACTER IN THIS POSITION
TDNN TC,[%SB9] ;IS IT AN INSERT SIGN BEFORE 9
JRST PICF3A ;NO
MOVE TD,SAVCP1 ;SAVE CHARACTER POS FOR FINISH: ERROR CHECK
MOVEM TD,SAVBCP ;BORROW SAVBCP TEMPORIARILY
TDNE PC,[%CHGEN] ;YES-- IS IT LEADING?
TLO PC,(%NOTLD) ;NO - SET FLAG
PICF3A: IOR PC,TC ;PUT FLAG IN PC
TRNE TB,%PLUS!%MINUS ;IS IT A SIGN?
DPB CH,MSKSYN ;YES--PUT IT IN SIGN POSITION
TDNE TC,[%FCHAR] ;NO--IS IT SUPPRESSION OR FLOAT?
DPB CH,MSKFLT ;YES--PUT IT IN FLOAT POSITION
TRNN TB,%S!%V!%P ;IS THIS S, P OR V?
ADDM PR,EXSIZE ;NO--ADD TO EXTERNAL SIZE
TDNE TC,[%CNTIN] ;DOES IT COUNT AS AN INTERNAL CHARACTER?
ADDM PR,INSIZE ;YES--ADD TO INTERNAL SIZE
TRNE PC,%.!%V ;IS IT AFTER DECIMAL POINT?
TDNN TC,[%CNTDP] ;IS IT A DECIMAL PLACE?
JRST .+2 ;NO
ADDM PR,DPSIZE ;YES--ADD TO DECIMAL PLACES
EXCH PR,DPSIZE
TRNE TC,%PBP ;IS THIS A "P" BEFORE A "V"?
SUB PR,DPSIZE ;YES--DECREMENT DECIMAL PLACES
EXCH PR,DPSIZE
TRNE TB,%CRDB ;IS IT "CR" OR "DB"?
AOS EXSIZE ;YES--ADD TO EXTERNAL SIZE AGAIN
MOVE TE,EXSIZE ;PICTURE TOO LARGE?
CAILE TE,MAXWSS
JRST PICERC ;YES--ERROR
TLNN TC,%FAP ;NO--IS IT FLOAT OR SUPPRESS AFTER POINT?
SKIPA TE,PICT2(ST) ;NO--GET MASK BYTE FROM TABLE
MOVEI TE,PIC9 ;YES--USE "9"
TRNE TB,%S!%P ;S AND P DON'T GO INTO MASK
JRST [ ; CHECK FOR IMPLIED V AND IF SO PUT IN MASK
TRNE TB,%P ;IS IT P
CAME PR,INSIZE ;FIRST CHARACTER?
JRST PSCAN2 ;NOT P OR NOT FIRST
;HAVE IMPLIED V
MOVEI TE,PICV ;GET V MASK CODE
MOVEI PR,1 ;BE SURE REPEAT IS 1
JRST .+1]
; DO WE HAVE A REPEAT TO PUT IN
CAIG PR,1 ;???
JRST PICF7 ;NO REPEAT
; INSERT REPEAT CODE
; <REPEAT CODE><#BYTES FOR BINARY COUNT><BYTE 1>...
TRNE TE,NORPT ;CAN IT BE REPEATED???
PUSHJ PP,PICERB ;NO - ERROR
MOVEI TD,PICRPT ;REPEAT MASK CODE
SOJL PICCNT,PICERH ; [404] WILL IT FIT??
IDPB TD,MP ;OK - STORE IT
PUSH PP,TA ;SAVE A COUPLE REGS
PUSH PP,TB
MOVEI TA,9 ;MAX NO BYTES FOR BINARY NUMBER (4 BITS)
MOVE TB,[POINT 4,PR] ;POINTER TO NUMBER
PICF6: ILDB TD,TB ;GET A BYTE
CAIN TD,0 ;IS IT NON-ZERO??
SOJN TA,PICF6 ;NO - GET NEXT ONE
;PUT COUNT OF BYTES IN
SOJL PICCNT,PICERJ ; [404] WILL IT FIT??
IDPB TA,MP ;OK - STORE IT
; NOW THE NUMBER ITSELF
PICF6A:
SOJL PICCNT,PICERJ ; [404] WILL BYTE FIT??
IDPB TD,MP ;OK - STORE IT
ILDB TD,TB ;GET ANOTHER
SOJG TA,PICF6A ;ANY LEFT??
POP PP,TB ;THATS ALL - RESTORE
POP PP,TA
; STORE MASK CHARACTER CODE
PICF7:
SOJL PICCNT,PICERH ; [404] WILL IT FIT???
IDPB TE,MP ;OK - STORE IT
JRST PSCAN2 ;TAKE IT FROM THE TOP
;ROUTINE TO GET AN INTEGER WITHIN PARENTHESES
GETRP: PUSHJ PP,GETCP0 ;TAKE LOOKAHEAD CHARACTER
MOVE PR,PICSAV ;[1124] GET CURRENT CHARACTER
CAIN PR,"S" ;[1124] CHECK FOR COMMON ERROR (MISSING 9)
EWARNW E.647 ;[1124] YES, TELL USER
MOVEI PR,0 ;CLEAR RESULT
GETRP1: PUSHJ PP,GETCPY ;GET A CHARACTER
CAIG CH,"9" ;IS IT A DIGIT?
CAIGE CH,"0"
JRST GETRP2 ;NO
IMULI PR,12 ;YES--ADD TO RESULT
ADDI PR,-"0"(CH)
CAIG PR,MAXWSS ;IS IT > LIMIT?
JRST GETRP1 ;NO--LOOP
MOVEI DW,E.316 ;YES, GIVE ERROR
DMOVE LN,SAVLN1
PUSHJ PP,FATAL
MOVEI PR,1 ;SET SIZE TO 1
GETRP4: PUSHJ PP,GETCPY ;GET A CHARACTER
CAIG CH,"9" ;IS IT A DIGIT?
CAIGE CH,"0"
JRST GETRP2 ;NO
JRST GETRP4 ;LOOP UNTIL WE GET OUT OF IT
GETRP2: JUMPLE PR,GETRP3 ;ERROR IF SIZE NOT POSITIVE
CAIN CH,")" ;WAS TERMINATOR A RIGHT PAREN?
PJRST GETKAR ;YES, JUST TO GET IN SYNC
GETRP3: POP PP,(PP) ;RETURN TO CALLER'S CALLER.
SETZM PICSAV ;CLEAR OLD CHAR
SKIPG PR
MOVEI PR,1
JRST PICERA
;THIS ROUTINE DECIDES IF THIS CHARACTER IS A FLOATER.
;IF IT IS, APPROPRIATE ACTION IS TAKEN
FLOAT: MOVEI TE,%ALLSH ;HAS THIS FLOATER BEEN SEEN BEFORE?
IMUL TE,TB
TDNN PC,TE
JRST FLOAT5 ;NO
FLOAT0:
TSWFS FFLOAT; ;YES--ARE WE ALREADY FLOATING?
JRST FLOAT4 ;YES
; CHECK FOR THE ILLEGAL CASE OF +$+++
; AND CLEAR THE LEADING SIGN BIT WHILE YOU ARE AT IT
TRNE TB,%MINUS!%PLUS ;IS IT A SIGN?
TLZE PC,(%NOTLD) ;YES, CLEAR AND TEST NOT LEADING FLAG
JRST FLOAT1 ;ITS NOT A LEADING SIGN
TRNE PC,%$ ;LEADING- WAS THERE A $ INSERT
JRST PICERB ;YES-- ERROR
FLOAT1: ANDCMI PC,(TB) ;TURN OFF INSERT FLAG
DPB CH,MSKFLT ;PUT CHARACTER IN FLOAT POSITION
TRNN PC,%V!%. ;HAS DECIMAL POINT BEEN SEEN?
CAIN SP,0 ;DO WE NEED TO SHIFT MASK
JRST FLOAT4 ;YES--LEAVE MASK ALONE
;SHIFT MASK LEFT ONE POSITION TO GET RID OF FIRST FLOATER.
MOVE TD,SP ;GET POSITION OF FIRST FLOATER
IBP TD ;ADVANCE ONE BYTE
FLOAT2: CAMN TD,MP ;CURRENT POSITION?
JRST FLOAT3 ;YES--DONE
ILDB TE,TD ;NO--MOVE A BYTE
IDPB TE,SP
JRST FLOAT2 ;LOOP
FLOAT3: MOVE MP,SP ;RESET MP
FLOAT4: LSH TC,1 ;SHIFT BIT
AOJA TA,CPOPJ## ;KICK UP TABLE POINTER AND SKIP
FLOAT5: MOVE SP,MP ;SAVE POINTER TO MASK POSITION
CAIG PR,1 ;IN A REPEAT??
POPJ PP, ; N0 - RETURN
AOS EXSIZE ;ADD 1 TO MAKE UP FOR IT HERE
MOVEI SP,0 ;CLEAR SO NO MASK SHIFT
SOJA PR,FLOAT0 ;SUBTRACT 1 FOR FLOATER
;PICTURE HAS BEEN SCANNED
FINISH: SKIPG EXSIZE ;[310] DOES THIS PIC PRODUCE ANY SIZE?
JRST PICERK ;[310] NO - THEN WE HAVE NO PICTURE.
;CHECK FOR SIGN IN MIDDLE WHICH COULD NOT BE CAUGHT BEFORE
;LIKE 00+00
TDNE PC,[%SB9] ;SIGN INSERT BEFORE 9 ?
TLNN PC,(%NOTLD) ;YES - WAS IT LEADING?
JRST FINSHF ;[1312] OK - NO SIGN OR LEADING SIGN
LDB CH,MP ;NOT LEADING BUT IS IT TRAILING?
CAIN CH,PICIS ;CHECK LAST MASK CHARACTER AGAINST INSERT SIGN
JRST FINSHF ;[1312] OK - ITS TRAILING
MOVE CP,SAVBCP ;NAUGHTY NAUGHTY - GET SIGN POSITION
MOVE LN,SAVLN1
MOVEI DW,E.51 ;INVALID PICTURE
PUSHJ PP,FATAL
JRST FINSH1 ;[1312]
FINSHF: LDB CH,[POINT 8,MSKWRD,19] ;[1312] GET FIRST 2 MASK BYTES
CAIN CH,204 ;[1312] IF SIGN AND COMMA,
JRST [LDB CH,[POINT 4,MSKWRD,23] ;[1347] YES, GET NEXT CHAR
CAIE CH,10 ;[1347] IS IT A FLOATING SIGN?
JRST FINSH1 ;[1347] NO, ASSUME USE KNOWS WHAT HE IS DOING
JRST FIN0ER] ;[1347] YES, WARN USER OF STRANGE PICTURE
LSH CH,-4 ;[1312] IF COMMA IS NOT FIRST
CAIE CH,4 ;[1312] AS IN +,+++ OR -,---
JRST FINSH1 ;[1312] ALL IS OK
FIN0ER: MOVEI DW,E.651 ;[1312] OTHERWISE, WARN ABOUT NO SIG. DIGIT
PUSHJ PP,WARNW## ;[1312] SPACE BEFORE COMMA
FINSH1: SKIPN FLGSW## ;ARE WE CHECKING FIPS LEVEL?
JRST FINSH0 ;NO
MOVE CH,PICSAV ;GET TERMINATING CHAR
CAIE CH,"," ;COMMA IS SPECIAL
CAIN CH,";" ;SO IS SEMI-COLON
TRNA
JRST FINSH0 ;NOT
EXCH LN,SAVLN1 ;POINT TO TERMINAL CHARACTER
EXCH CP,SAVCP1 ; NOT THE LOOKAHEAD ONE
PUSHJ PP,FLG.HI## ;TEST AT HIGH-INTERMEDIATE LEVEL
EXCH LN,SAVLN1
EXCH CP,SAVCP1
FINSH0: MOVE CH,SAVCP1 ;GET CHARACTER POSITION OF LAST NON-BLANK
ADDI CH,1 ;BUMP IT BY 1
MOVEM CH,SAVBCP ;THAT IS WHERE LAST BLANK WAS
MOVE CH,SAVLN1 ;THIS IS WHERE
MOVEM CH,SAVBLN ; LAST BLANK WAS
MOVEI CH,ENDPIC ;STASH A TERMINATOR IN MASK
IDPB CH,MP
TSWF FCLAS2; ;STILL ALPHABETIC?
JRST FINSH2 ;YES
TRNN PC,%X ;NO--ANY "X" OR "A"?
SWONS FCLAS1; ;NO--IT IS NUMERIC
SWOFFS FCLAS1!FCLAS2 ;YES--IT IS ALPHANUMERIC
JRST FINSH2 ;FOR NUMERICS
; FOR ALPHANUMERICS CHECK AND SEE IF THEY ARE EDITED AND THEN
; CHANGE ALL 9'S TO X'S IF SO
TDNN PC,[%EDIT] ;HAVE WE SEEN ANY EDITING CHARACTERS?
JRST FINSH2 ;NO
MOVE TA,MSKPTR ;GET STARTING MASK POINTER
MOVEI TB,PICXA ;SET UP X CODE
FINSH3: ILDB CH,TA ;GET MASK CHARACTER
CAIE CH,PICRPT ;REPEAT??
JRST FINSH4 ;NO
ILDB CH,TA ;SKIP REPEAT - GET COUNT
IBP TA ;SKIP OVER IT
SOJG CH,.-1
ILDB CH,TA ;GET THE CHARACTER
FINSH4: CAIN CH,PIC9 ;IS IT A 9 ??
DPB TB,TA ;YES - CHANGE IT TO AN X
CAIE CH,ENDPIC ; ARE WE DONE?
JRST FINSH3 ;NOT YET
FINSH2: TDNE PC,[%SIGN] ;ANY SIGN?
SWON FSIGN; ;YES--SET FLAG
TDNE PC,[%FCHAR] ;ANY FLOAT OR SUPRESSION CHARS?
SETOM FLOTBZ ;SET POSSIBLE BLANK WHEN ZERO
TRNE PC,%9 ;ANY 9'S SEEN?
SETZM FLOTBZ ;YES
TDNE PC,[%EDIT] ;ANY EDITING CHARACTERS?
SWON FEDIT; ;YES--SET FLAG
MOVEM SW,SAVEAC+SW ;SAVE SW
MOVEI TB,0
LDB TA,MSKSYN ;GET SIGN CHARACTER
CAIN TA,"-"-40 ;IS IT MINUS?
DPB TB,MSKSYN ;YES--REPLACE WITH SPACE
LDB TA,MSKFLT ;GET FLOAT CHARACTER
CAIE TA,"-"-40 ;IS IT MINUS?
CAIN TA,"Z"-40 ;NO--IS IT "Z"?
DPB TB,MSKFLT ;YES--REPLACE WITH SPACE
SUB MP,MSKPTR ;COMPUTE MSKSIZ
MOVEI MP,1(MP)
MOVEM MP,MSKSIZ
TSWT FCLAS1 ;IS IT NUMERIC?
JRST FINSH9 ;NO
MOVE CH,INSIZE ;YES-- > 18 DIGITS?
CAIG CH,^D18
JRST FINSH5 ;NO
MOVEI DW,E.330 ;YES--ERROR
PUSHJ PP,FATALW
MOVEI CH,^D18 ;JAM SIZE OF 18
MOVEM CH,INSIZE
MOVE CH,DPSIZE ;MORE THAN 18 DECIMAL PLACES, TOO?
CAIG CH,^D18
JRST FINSH9 ;NO, OK NOW
MOVEI CH,^D18 ;JUST QUIETLY STICK 18 IN HERE, TOO
MOVEM CH,DPSIZE ; 'CAUSE WE ALREADY COMPLAINED ABOUT IT
JRST FINSH9
FINSH5: MOVE CH,DPSIZE ;CHECK FOR TOO MANY DECIMAL PLACES IN ITEM
CAIG CH,^D18
JRST FINSH9 ;NO, OK
MOVEI DW,E.602 ; ?TOO MANY DECIMAL PLACES
PUSHJ PP,FATALW
MOVEI CH,^D18 ;MAKE IT 18
MOVEM CH,DPSIZE
FINSH9: MOVSI HI,SAVEAC ;RESTORE ACCUMULATORS
BLT HI,HI-1
MOVE HI,SAVEAC+HI
POPJ PP,
;ERROR--INVALID PICTURE CHARACTER
PICERA: MOVEI DW,E.51
JRST PICER1
;ERROR--INVALID COMBINATION OF CHARACTERS
PICERB: POP PP,DW ;THROW AWAY A PP ENTRY
MOVEI DW,E.52
JRST PICER1
;ERROR--TOO LARGE A FIELD
PICERC: MOVEI DW,E.316
PICER1: DMOVE LN,SAVLN1
PICERR: PUSHJ PP,FATAL ;[310] PUT OUT A DIAGNOSTIC
PICER2: MOVEM CH,SAVEAC+CH ;SAVE THE CHARACTER
SKIPN CH,PICSAV ;LOOKAHEAD CHAR??
PUSHJ PP,GETCPY ;SCAN UNTIL SPACE SEEN
SETZM PICSAV ;DON'T LOOK AT THIS ANYMORE
PICER3: CAIE CH," "
JRST PICER2
MOVE CH,SAVEAC+CH ;GET BACK NEXT TO LAST CHARACTER
CAIN CH,"." ;WAS IT A PERIOD?
SWON FGTPER ;YES--SET "GET A PERIOD" FLAG
JRST FINSH1 ;SKIP ERROR CHECK AT BEGINNING OF FINISH
;ERROR--WORD STARTED WITH "I" BUT WAS NOT "IS"
PICERD: MOVEM CH,SAVEAC+CH
MOVEI DW,E.182
PUSHJ PP,FATALW
SETZM PICSAV ;NO LOOKAHEAD CHARACTER
JRST PICERG
;ERROR--"C" OR "D" NOT FOLLOWED BY PROPER CHARACTER
PICERF: DMOVE LN,SAVLN1
MOVEM CH,SAVEAC+CH
MOVEI DW,E.51
PUSHJ PP,FATAL
PICERG: MOVE CH,SAVEAC+CH
JRST PICER3
;ERROR--PICTURE TOO LARGE
PICERJ: POP PP,TB ; [402] RESTORE PUSH DOWN POINTER
POP PP,TA ; [402] BEFORE GIVING ERROR
PICERH: MOVEI DW,E.72
JRST PICER1
; ERROR NO PICTURE - BECAUSE PIC DELIMITER NOT A SPACE - PROBABLY A PERIOD.
PICERL: MOVEI DW,E.220 ;[310] PICTURE REQUIRED
DMOVE LN,SAVELN ;[310] GET SOURCE LINE & POSITION
JRST PICERR ;[310] PUT OUT DIAGNOSTIC
; ERROR NO PICTURE BECAUSE DESCRIPTION PRODUCED NO SIZE.
PICERK: MOVEI DW,E.220 ;[310] PICTURE REQUIRED
DMOVE LN,SAVLN1 ;[310] GET LINE & POSITION
PUSHJ PP,FATAL ;[310] GIVE FATAL ERROR.
JRST FINSH1 ;[310] FINISH UP
;GET A CHARACTER, IF THE CHARACTER IS NOT A SPACE
;CONVERT TO UPPER CASE, SAVE LINE AND CHARACTER POSITION.
GETCPY: PUSHJ PP,GETKAR
;ENTRY TO SAY YOU HAVE TAKEN CHARACTER WHEN YOU ALREADY HAVE IT
GETCP0: CAIN CH," "
POPJ PP,
PCONVL: IDPB CH,PICPTR ;[211] STORE ACTUAL CHAR.
CAIL CH,"a" ;[211] CONVERT LC A-Z TO UC
CAILE CH,"z" ;[211]
CAIA ;[211]
TRZ CH,40 ;[211] CHANGE LC TO UPPER
MOVEM LN,SAVLN1
MOVEM CP,SAVCP1
POPJ PP,
;CONSTANTS USED BY ROUTINE
FLTIND=3 ;THE MASK BYTE FOR A FLOAT
ENDPIC=17 ;THE MASK BYTE FOR PICTURE TERMINATION
PICXA=00 ;THE MASK BYTE FOR "X" OR "A"
PICIS=10 ;THE MASK BYTE FOR SIGN INSERT
PIC9=01 ;THE MASK BYTE FOR "9"
PICRPT=16 ;REPEAT MASK CODE
PICV=14 ;V MASK CODE
MSKPTR: POINT 4,MSKWRD,11 ;BYTE POINTER TO FIRST MASK BYTE
MSKSYN: POINT 6,MSKWRD,5 ;BYTE POINTER TO SIGN CHARACTER
MSKFLT: POINT 6,MSKWRD,11 ;BYTE POINTER TO FLOAT OR SUPPRESSION CHARACTER
EXTERNAL INSIZE, EXSIZE, DPSIZE, MSKWRD, MSKSIZ, SAVEAC, MAXWSS
EXTERNAL WORDCP, WORDLN, SAVCP1, SAVLN1, SAVBCP, SAVBLN, SAVELN, SAVECP
;THE FOLLOWING ARE BITS SET BY THE SCANNER
%NOTLD=1B0 ;IF SET THE FIXED INSERT SIGN BEFORE 9 OR . IS NOT LEADING
%P=1B18 ;FOR "P"
%Z=1B19 ;FOR "Z"
%STAR=1B20 ;FOR "*"
%$=1B22 ;FOR CURRENCY SIGN
%PLUS=1B24 ;FOR "+"
%MINUS=1B26 ;FOR "-"
%9=1B27 ;FOR "9"
%V=1B28 ;FOR "V"
%S=1B29 ;FOR "S"
%X=1B30 ;FOR "X" AND "A"
%CRDB=1B31 ;FOR "CR" AND "DB"
%.=1B32 ;FOR "."
%COMMA=1B33 ;FOR ","
%0=1B34 ;FOR "0"
%B=1B35 ;FOR "B"
;THE FOLLOWING ARE USEFUL COMBINATIONS
%ZSTAR=%Z!%STAR ;THE SUPPRESSION CHARACTERS
%FLOAT=%PLUS!%MINUS!%$ ;THE FLOATING CHARACTERS
%SPECI=%B!%0!%COMMA ;SPECIAL INSERTION CHARACTERS
%SPEC.=%ZSTAR!%FLOAT!%P ;TREATED DIFFERENTLY AFTER DECIMAL POINT
;SOMETIMES THE BITS ARE SHIFTED BY FOLLOWING AMOUNTS
SHIFTF=2 ;WHEN A FLOAT CHARACTER
SHIFT9=1000 ;WHEN AFTER A "9"
SHIFT.=20000 ;WHEN AFTER THE DECIMAL PLACE
%ALLSH=<SHIFT.+1>*<SHIFTF+1> ;POSSIBLE SHIFTS FOR FLOATER
;MORE USEFUL COMBINATIONS
%SB9=<%PLUS!%MINUS>*<1!SHIFT.> ;SIGN BEFORE 9
%SA9=%SB9*SHIFT9 ;SIGN AFTER 9
%SBP=<%PLUS!%MINUS>*SHIFTF ;SIGN FLOATED BEFORE DECIMAL POINT
%SAP=%SBP*SHIFT. ;SIGN FLOATED AFTER DECIMAL POINT
%ZBP=%Z!%STAR ;SUPPRESSION BEFORE DECIMAL POINT
%ZAP=%ZBP*SHIFT. ;SUPPRESSION AFTER DECIMAL POINT
%$BP=%$*SHIFTF ;CURRENCY SIGN FLOATING
%$AP=%$BP*SHIFT. ;CURRENCY SIGN FLOATING AFTER POINT (ILLEGAL)
%PAP=%P*SHIFT. ;"P" AFTER A DECIMAL POINT
%PBP=%P ;"P" BEFORE A DECIMAL POINT
%FCHAR=%ZBP!%ZAP!%SBP!%SAP!%$BP!%$AP ;A SUPPRESSION OR FLOAT CHARACTER
%FAP=<%SAP!%ZAP!%$AP>/1000000 ;FLOATING OR SUPPRESSION AFTER POINT
%SIGN=%SB9!%SA9!%SBP!%SAP!%CRDB!%S ;ALL SIGNS
%EDIT=-1-<%PBP!%PAP!%9!%V!%S!%X> ;CHARACTERS WHICH CAUSE EDITING
%CNTIN=%9!%X!%FCHAR ;THESE COUNT AS INTERNAL CHARACTERS
%CNTDP=%9!%FCHAR!%PAP ;THESE COUNT AS DECIMAL PLACES
;%FB9AP=%FLOAT*SHIFT./1000000 ;+, - OR $ BEFORE 9 BUT AFTER POINT
%CHGEN=-1-<%PAP!%PBP!%V!%S> ;THINGS WHICH DEFINE CHARACTERS IN DESTINATION FIELD
;A TABLE OF ALLOWABLE CHARACTERS WITHOUT SPECIAL CHARACTERISTICS
; LH IS RELATIVE POSITION OF ENTRY IN PICT2 AND PICT3.
; RH IS THE CHARACTER IN ASCII
PICT1: XWD 00,"X" ;X
XWD 01,"9" ;9
XWD 02,"V" ;V
XWD 14,"-" ;-
XWD 03,"S" ;S
XWD 20,"Z" ;Z
XWD 21,"*" ;*
XWD 12,"+" ;+
XWD 04,"B" ;B
XWD 05,"0" ;0
XWD 00,"A" ;A
XWD 22,"P" ;P
XWD 23,"/" ;/
PICT1S=.-PICT1
;A TABLE OF MASK VALUES AND INITIAL BIT SETTINGS
; LH IS INITIAL BIT SETTING FOR "PC"
; RH IS THE MASK VALUE FOR THE CHARACTER.
NORPT=1B18 ;CHARACTER CANNOT BE REPEATED
PICT2: XWD %X,00 ;X AND A
XWD %9,01 ;9
XWD %V,14!NORPT ;V
XWD %S,00!NORPT ;S (NOT USED IN MASK)
XWD %B,05 ;B
XWD %0,06 ;0
XWD %COMMA,04 ;COMMA
XWD %.,11!NORPT ;DECIMAL POINT
XWD %CRDB,12!NORPT ;CREDIT
XWD %CRDB,13!NORPT ;DEBIT
XWD %PLUS,10!NORPT ;+ INSERT
XWD 0,FLTIND ;+ FLOATED
XWD %MINUS,10!NORPT ;- INSERT
XWD 0,FLTIND ;- FLOATED
XWD %$,07!NORPT ;CURRENCY SIGN INSERT
XWD 0,FLTIND ;$ FLOATED
XWD %Z,02 ;Z
XWD %STAR,02 ;*
XWD %P,00 ;P (NOT USED IN MASK)
XWD %0,15 ;/
VALAP==%PAP!%ZAP!%SAP!%$AP
VALBP==%PBP!%ZBP!%SBP!%$BP
VALS1==1+SHIFT.
VALS2==SHIFTF*VALS1
VALX1==%SPECI!%.!%$!%PAP!%V
VALX2==%SPECI!%.!%SB9!%PAP!%V
; THE TRUTH TABLE
DEFINE FALSE (A), <EXP A> ;THESE FLAGS ARE NOT ALLOWED
DEFINE TRUE (A),<EXP -1-A> ;THESE FLAGS ARE ALLOWED
DEFINE TPICT3,<
XLIST
TRUE <%B!%0!%X!%9> ;X,A
FALSE <%SA9!%CRDB!%PBP!%ZAP!%SAP!%$AP!%NOTLD> ;9
FALSE <%.!%X!%PAP!%V!%ZAP!%SAP!%$AP> ;V
TRUE 0 ;S
FALSE <%SA9!%CRDB!%PBP!%S> ;B
FALSE <%SA9!%CRDB!%PBP!%S> ;0
FALSE <%SA9!%CRDB!%X!%PBP!%S> ;COMMA
TRUE <%SPECI!%SB9!%$!VALBP!%9!%NOTLD> ;DECIMAL POINT
FALSE <%SIGN!%X> ;CR
FALSE <%SIGN!%X> ;DB
FALSE <%SIGN!%X> ;INSERT + BEFORE 9,.
TRUE <%SPECI!%$!<%PLUS*SHIFTF>!%NOTLD> ;FLOAT + BEFORE 9,.
FALSE <%SIGN!%X> ;INSERT - BEFORE 9,.
TRUE <%SPECI!%$!<%MINUS*SHIFTF>!%NOTLD> ;FLOAT - BEFORE 9,.
TRUE <%SPECI!%SB9!%PAP!%V> ;INSERT $ BEFORE 9,.
TRUE <%SPECI!%SB9!%$BP> ;FLOAT $ BEFORE 9,.
TRUE <%SPECI!%SB9!%$!%Z> ;Z BEFORE POINT
TRUE <%SPECI!%SB9!%$!%STAR> ;* BEFORE POINT
FALSE <%.!%X!%V!VALAP!%NOTLD> ;P BEFORE POINT
FALSE <%SIGN!%X> ;INSERT + AFTER 9, BEFORE .
TRUE 0 ;FLOAT + AFTER 9, BEFORE .
FALSE <%SIGN!%X> ;INSERT - AFTER 9, BEFORE .
TRUE 0 ;FLOAT - AFTER 9, BEFORE .
FALSE <%SIGN!%X> ;INSERT + BEFORE 9, AFTER .
TRUE <VALX1!<%PLUS*VALS2>!%NOTLD> ;FLOAT + BEFORE 9, AFTER .
FALSE <%SIGN!%X> ;INSERT - BEFORE 9, AFTER .
TRUE <VALX1!<%MINUS*VALS2>!%NOTLD> ;FLOAT - BEFORE 9, AFTER .
TRUE <%SB9!%PAP!%V!%.> ;INSERT $ BEFORE 9, AFTER .
TRUE <VALX2!%$BP!%$AP> ;FLOAT $ BEFORE 9, AFTER .
TRUE <VALX2!%$!<%Z*VALS1>> ;Z AFTER POINT
TRUE <VALX2!%$!<%STAR*VALS1>> ;* AFTER POINT
TRUE <%PAP!%S!%V!%$!%PLUS!%MINUS> ;P AFTER POINT
FALSE <%SIGN!%X> ;INSERT + AFTER 9,.
TRUE 0 ;FLOAT + AFTER 9,.
FALSE <%SIGN!%X> ;INSERT - AFTER 9,.
TRUE 0 ;FLOAT - AFTER 9,.
LIST>
PICT3: TPICT3;
END