TITLE 'APLFMT-B00,10/10/73,DWG702985' SYSTEM SIG7F APLFMT@ CSECT 1 * * DEF'S DEF APLFMT@ DEF DELTAFMT * * REF'S * REF ALOCBLK ROUTINE TO ALLOCATE DATA BLOCK REF ALOCHNW ALLOCATE DATA BLOCK-N WORDS+HEADER REF BITMASK TABLE OF 1 BIT MASKS REF BREAKFLG BREAK FLAG REF CURRCS CURRENT CODESTRING POINTER REF DXRETURN DYADIC EXECUTION RETURN REF ERDOMAIN DOMAIN ERROR REF ERFORMAT FORMAT SYNTAX ERROR REF ERRANK RANK ERROR REF F0F9 CONSTANTS 'F0' AND 'F9' REF FLHALF FL. PT. LONG 0.5 U21-0004 REF FMTMPS BASE OF TEMPS FOR DELTAFMT-DW BOUND- REF LETTERS DW 'A','Z' REF LFARG LEFT ARGUMENT POINTER REF OFFSET CODESTRING OFFSET REF OPBREAK TRANSFER POINT FOR BREAK REF PLUSREAL ENTRY TO REAL # CONV ROUTINE REF RESULT RESULT POINTER REF RTARG RIGHT ARGUMENT POINTER REF SINGOUT ROUTINE TO WRITE A DATA BLOCK REF STATEPTR STATE POINTER REF TENSTBL TABLE OF INTEGER POWERS OF 10 REF X4E1 CONST. USED TO FIX FL. PT. NO. U21-0006 REF ZEROZERO DW ZERO * * TEMPS FOR APLFMT-LOCATED IN APLUTSI (CSECT 0) * DOUBLE-WORD-GROUPS NROWS EQU FMTMPS DWB MAX # OF ROWS @@@@@@@ NCOLS EQU FMTMPS+1 TOTAL # OF COLUMNS @ ARGWORDS EQU FMTMPS+2 DWB-DW ARG ADDRESS AND COUNT @ ARGADR EQU FMTMPS+4 DWB ARG POINTER ADDRESS @ ARGCOUNT EQU FMTMPS+5 ARG COUNT @ ARGROWS EQU FMTMPS+6 DWB # OF ARG ROWS @ ARGCOLS EQU FMTMPS+7 # OF ARG COLUMNS @ SAVEREAL EQU FMTMPS+8 DW SAVE LOC FOR REAL VALUE * @@@@@@@ * DECORATOR ADDRESS AND LENGTH TEMPS * DECORTEX EQU MTEXT-1STDECOR TABLE OFFSET @@@@@@@ MTEXT EQU FMTMPS+20 ADDRESSES OF DECORATORS @ NTEXT EQU MTEXT+1 @ PTEXT EQU MTEXT+2 @ QTEXT EQU MTEXT+3 @ RTEXT EQU MTEXT+4 @@@@@@@ * DECORLEN EQU MLENGTH-1STDECOR TABLE OFFSET @@@@@@@ MLENGTH EQU FMTMPS+25 LENGTHS OF DECORATORS NLENGTH EQU MLENGTH+1 @ PLENGTH EQU MLENGTH+2 @ QLENGTH EQU MLENGTH+3 @ RLENGTH EQU MLENGTH+4 @@@@@@@ * * SINGLE TEMPS-SPACE LEFT FOR INSERTION OF OTHERS-ALPHABETIC ORDER * COMMACNT EQU FMTMPS+40 COMMA COUNT COMMALOC EQU FMTMPS+42 COMMA INSERTION LOCATION DATALOC EQU FMTMPS+44 DATUM ADDRESS DATASPEC EQU FMTMPS+46 FLAG TO INDICATE DATA USE DORS EQU FMTMPS+48 'D' OR 'S' SPECIFICATION EXPSTART EQU FMTMPS+52 EXPONENT STARTING CHAR POS FORMLIM EQU FMTMPS+54 FORMAT POINTER LIMIT GAPSIZE EQU FMTMPS+56 SIZE OF FIELD GAP INTLEFT EQU FMTMPS+58 LOCATION LEFT END OF INTEGER PART INTRIGHT EQU FMTMPS+60 LOCATION RIGHT END OF INTG. PART INTSIZE EQU FMTMPS+62 SIZE OF INTEGER PART LDFLAG EQU FMTMPS+63 LONG DIVIDE FLAG LOGLBITS EQU FMTMPS+64 LOGICAL DATA BITS LOGLCNT EQU FMTMPS+65 LOGICAL DATA BIT COUNT LOWEND EQU FMTMPS+66 LOW END OF # IN LONG DIVIDE NSIZE EQU FMTMPS+67 # OF DIGITS IN R8-R9 TO BE CNVRTD RESLTPTR EQU FMTMPS+68 INITIAL ADDRESS OF RESULT DATA RESWIDTH EQU FMTMPS+70 # OF CHARACTERS/ROW OF RESULT RETAIN EQU FMTMPS+72 FLAG INDICATING RETAIN OR DISPLAY ROWINDEX EQU FMTMPS+74 INDEX OF ROW BEING PROCESSED RPTCOUNT EQU FMTMPS+76 REPEAT COUNT FOR A FORMAT TEXTADR EQU FMTMPS+78 TEXT STRING ADDRESS VALFLAG EQU FMTMPS+80 VALUE FLAG;NEG,ZERO,OR POS * * REGISTER DESIGNATIONS * R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 * * CHARACTER CODES * END EQU -1 END-OF-FORMAT MINUSIGN EQU X'72' NEGATIVE CONSTANT SIGN QUADQUOT EQU X'52' QUOTE-QUAD UNDRSCOR EQU X'6D' UNDERSCORE BOSCODE EQU 37 BEGINNING OF STATEMENT * * FORMAT SPECIFIER VALUES:BITS * IFORMAT EQU 1 FORMAT CODES I FFORMAT EQU 2 F EFORMAT EQU 3 E AFORMAT EQU 4 A XFORMAT EQU 5 X TFORMAT EQU 6 T * BBIT EQU 1 QUALIFIER BIT FLAGS B CBIT EQU 2 C LBIT EQU 4 L ZBIT EQU 8 Z MBIT EQU X'10' DECORATION BITS M NBIT EQU X'20' N PBIT EQU X'40' P QBIT EQU X'80' Q RBIT EQU X'100' R * * DATUM TYPE CODES * LOGL EQU 1 LOGICAL (BIT) CHAR EQU 2 TEXT (BYTE) INTG EQU 3 INTEGER (WORD) FLOT EQU 4 REAL (DW) INDSEQ EQU 5 INDEX SEQ-HANDLED AS INTEGER LIST EQU 6 LIST BOUND 8 FESPEC DATA FFORMAT,EFORMAT 2,3 * ONE EQU BITMASK+1 TWO EQU FESPEC 2 THREE EQU FESPEC+1 3 X1F DATA X'1F' MASK XFF DATA X'FF' MASK * * TABLES FOR FORMAT SCAN ROUTINES * SPECTBL TEXTC 'IFEAXBCLZMNPQR' FORMAT, QUAL, AND DECOR SPEC'S. * 1STQUAL EQU 6 INDEX OF 1ST QUALIFIER SPEC. 1STDECOR EQU 10 INDEX OF 1ST DECORATION SPEC. * QDBITS EQU %-1STQUAL DATA BBIT DATA CBIT DATA LBIT DATA ZBIT DATA MBIT DATA NBIT DATA PBIT DATA QBIT DATA RBIT * DEFAULTS EQU %-1 DEFAULT DECORATION DATA DATA BA(DSTR) M TEXT DATA BA(DSTR)+1 N TEXT DATA BA(DSTR)+1 P TEXT DATA BA(DSTR)+1 Q TEXT DATA BA(DSTR)+2 R TEXT DATA 1,0,0,0,1 * DSTR DATA,1 MINUSIGN,QUADQUOT,' ',QUADQUOT * * DELTAFMT-DYADIC SCALAR TO PROVIDE FORMATTED OUTPUT FOR PRINTING * OR INTERNAL ASSIGNMENT * * THE FIRST SECTION OF CODE- DELTAFMT TO FMT9 -CONCERNS ANALYSIS OF * ARGUMENTS AND GENERATION OF RESULT STRUCTURE * * THE LEFT ARGUMENT MUST BE A TEXT VECTOR, THE CONTENTS OF WHICH * MUST BE VALID SPECIFICATION FORMS FOR OUTPUT CONVERSION AND * FORMATTING * * THE RIGHT ARGUMENT MAY BE ANY VALID 'DATA' TYPE WITH RANK 2 OR * LESS OR A 'LIST' OF RANK 1,WHOSE ELEMENTS ARE VALID DATA BLKS * * THE RESULT WILL BE A TEXT VECTOR OR MATRIX: * A MATRIX IS POSSIBLE ONLY IF THE RIGHT ARGUMENT INDICATES * MORE THAN ONE 'ROW' OF RESULT AND THE RESULT IS TO BE * RETAINED-THAT IS-THE NEXT ITEM IN APL CS EXECUTION IS * NOT 'BEGINNING OF STATEMENT' * CATQ EQU 7 EXECUTE OR EVALUATED INPUT * CATEGORY FOR STATE ENTRY. LOCAL FMT1,FMT2,FMT3,FMT4,FMT5,FMT6,FMT7,FMT8,FMT9 DELTAFMT LI,R1 CATQ TEST FOR EXEC. OR EVAL INPUT CB,R1 *STATEPTR BE SRETAIN IF SO,SET TO RETAIN DATA LW,R1 OFFSET CHECK IF AI,R1 -1 RESULT IS FOR LB,R1 *CURRCS,R1 OUTPUT ONLY-THAT IS- AI,R1 -BOSCODE FOR BEGINNING OF STATEMENT SRETAIN STW,R1 RETAIN 0=DON'T RETAIN-DISPLAY ONLY LB,R1 *LFARG CHECK LEFT ARGUMENT CI,R1 CHAR FOR DOMAIN BNE ERDOMAIN AND RANK LH,R1 *LFARG AI,R1 -CHAR*X'100'-1 BNEZ ERRANK STD,R1 NROWS AND NCOLS -INITIALIZE MAX ROWS AND COLUMNS BAL,R14 INITARG SET UP FOR ARGUMENT SCAN FMT1 BAL,R14 GETARG GET NEXT ARGUMENT-INCLUDES RANK CHK B FMT3 NO MORE CW,R8 NROWS BLE FMT2 STW,R8 NROWS UPDATE MAXROWS IF INDICATED FMT2 AWM,R9 NCOLS UPDATE MAXCOLS CI,R5 LIST CHECK DATA TYPE BL FMT1 OK B ERDOMAIN ERROR-LIST OR HIGHER FMT3 LW,R8 NROWS BEZ NULRESLT NO DATA-NULL RESULT LI,R1 0 STW,R1 RESWIDTH PRESET RESULT WIDTH TO 0 LW,R1 NCOLS SET # OF COLUMNS BEZ NULRESLT IF DATA COLUMN COUNT=0 GIVE NULL RES BAL,R14 INITFORM INITIALIZE FORMAT SCAN FMT4 BAL,R12 FPHRASE SCAN A FORMAT PHRASE AWM,R3 RESWIDTH ADJUST RESULT WIDTH CI,R4 AFORMAT CHECK IF FORMAT USES DATUM BG FMT4 NO,KEEP SEARCHING AI,R1 -1 YES-DECREMENT BGZ FMT4 LOOP IF ALL DATA COLUMNS NOT USED FMT5 BAL,R12 FPHRASE DATA IS USED UP-CHECK FOR RESWCHK CI,R4 AFORMAT TRAILING NON-DATA FORMAT PHRASES BLE FMT6 NO-DATA USER ENCOUNTERED AWM,R3 RESWIDTH YES-KICK FIELD SIZE B FMT5 AND LOOP NOWRAP RES 0 RETURN FROM FPHRASE IF 'END' REACHED FMT6 LW,R11 NROWS NO. OF ROWS U21-0008 LW,R9 RETAIN MATRIX-CHECK IF TO BE RETAINED BNEZ FMT7 YES U21-0010 LI,R11 1 FMT7 LW,R8 R11 SAVE EFFECTIVE NROWS IN R8 U21-0012 FMT8 MW,R11 RESWIDTH # OF BYTES AI,R11 11 'BOUND 4' ROUND UP +8 BYTES U21-0014 * FOR LENGTH WORDS U21-0015 SAS,R11 -2 # OF WORDS BAL,R7 ALOCHNW GET DATA BLOCK STW,R4 RESULT ASSIGN TO RESULT LW,R7 RESULT AI,R7 4 POINT TO DATA U21-0018 LI,R2 CHAR*X'100'+2 CHARACTER MATRIX U21-0019 STH,R2 *RESULT SET TYPE AND RANK STW,R8 -2,R7 SET # OF ROWS LW,R9 RESWIDTH SET NO. OF COLUMNS U21-0022 STW,R9 -1,R7 SET # OF COLUMNS SLS,R7 2 STW,R7 RESLTPTR SET R7 TO POINT TO BA-RESULT B MAINSCAN LOCAL NULRESLT LI,R11 4 EMPTY RESULT-QUIT BAL,R7 ALOCBLK LI,R11 X'0201' TEXT VECTOR STH,R11 *R4 LI,R11 0 STW,R11 2,R4 STW,R4 RESULT B DXRETURN * * MAINSCAN-THIS IS THE DRIVER TO ACTUALLY GENERATE A RESULT OR RESULTS * USES THE INDICATED SUBROUTINES TO SCAN THE FORMAT STATEMENT * -REPEATEDLY IF NECESSARY-UNTIL DATA IN RIGHT ARGUMENT IS * EXHAUSTED * MAINSCAN BAL,R14 INITARG INITIALIZE FOR 'GETARG' BAL,R14 INITDATA INITIALIZE FOR 'GETDATUM' NEXTROW BAL,R14 INITFORM INITIALIZE FOR 'FPHRASE' MTW,1 ROWINDEX INCREMENT ROW INDEX LI,R8 1 STW,R8 ARGCOLS INITIALIZE ARGUMENT COLUMN # LD,R8 ARGWORDS INITIALIZE ARG ADDRESS AND COUNT STD,R8 ARGADR AND ARGCOUNT NXPHRASE BAL,R12 FPHRASE SCAN NEXT FORMAT PHRASE FTYPETBL B FTYPETBL,R4 @@@@@@@ B IFORMGEN IW @ B FFORMGEN FW.D @ B EFORMGEN EW.D @ B AFORMGEN AW @ B XFORMGEN XW @ B TFORMGEN 'TEXT' @@@@@@@ ENDROW LW,R13 BREAKFLG CHECK FOR BREAK BNEZ OPBREAK YES-GET OUT LW,R8 ROWINDEX CW,R8 NROWS BGE DXRETURN BAL,R13 SENDROW NO-OUTPUT ROW IF INDICATED B NEXTROW PROCEED * * SENDROW-IF RETAIN=0 :OUTPUT THE CURRENT ROW * SINGOUT USED-SAVES & RESTORES REGISTERS * R7 SET TO START OF RESULT DATA BLOCK,WHICH * IS REUSED * IF RETAIN NOT=0, RETURNS WITH NO ACTION * SENDROW LW,R1 RETAIN CHECK IF DATA TO BE RETAINED BNEZ *R13 YES-NO DISPLAY LW,R4 RESULT BAL,R14 SINGOUT OUTPUT RESULT B OPBREAK (ERROR RETURN-VERY UNLIKELY) LW,R7 RESLTPTR RESET POINTER TO RE-USE B *R13 PAGE * * TFORMGEN-TEXT GENERATION * TFORMGEN LW,R1 TEXTADR ADDRESS LW,R2 R3 COUNT BAL,R14 PUTSTRNG PUT'EM B NXPHRASE RETURN * * XFORMGEN-OUTPUT BLANKS * XFORMGEN LW,R1 R3 COUNT BAL,R14 PUTBLNKS PUT'EM B NXPHRASE RETURN * * AFORMGEN-OUTPUT TEXT AND,AS INDICATED, BLANKS * AFORMGEN BAL,R13 GETDATUM GET DATUM CI,R5 CHAR CHECK FOR CHAR DATA BNE ERDOMAIN AFORM1 LW,R1 R3 GET W AI,R1 -1 CHECK IF 1 BLEZ AFORM2 YES-NO BLANKS BAL,R14 PUTBLNKS NO-STUFF W-1 BLANKS AFORM2 STB,R8 0,R7 STUFF THE CHARACTER AI,R7 1 B NXPHRASE CONTINUE * * * EFORMGEN- E FORMAT PROCESSOR * * GENERATES ONE FIELD ENTRY * DORS=NO OF DIGITS PRINTED * W=FIELD WIDTH * * MAY EXIT TO OVERFLOW NORMAL EXIT TO NXPHRASE * LOCAL EFORM1,EFORM2,EFORM3,EFORM4,EFORM5 EFORMGEN BAL,R13 GETDATUM GET A VALUE CI,R5 CHAR CHECK FOR TEXT BE ERDOMAIN YES-ERROR LCW,R1 DORS -S BIR,R1 EFORM0 1-S AI,R1 1 IF S=1, 2-5 EFORM0 AW,R1 R3 W+1-S OR,IF S=1, W+2-S LW,R0 VALFLAG BGEZ EFORM1 AI,R1 -1 SPACE FOR SIGNBIT EFORM1 AI,R1 -6 R1=W-S-4(FOR 'E+XX') * -1(FOR DECIMAL PT-UNLESS S=1) * -1(FOR SIGN BIT IF VALUE NEGATIVE) BEZ EFORM2 JUST RIGHT BLZ ERFORMAT W AND S NOT COMPATIBLE BAL,R14 PUTBLNKS NEEDS LEADING BLANKS EFORM2 LW,R0 VALFLAG BGEZ EFORM3 CHECK FOR '-' LI,R0 MINUSIGN STB,R0 0,R7 AI,R7 1 EFORM3 LW,R2 NSIZE # OF DIGITS IN R8-R9 VALUE LW,R11 DORS # OF DIGITS TO BE PRINTED LI,R12 1 # OF DIGITS LEFT OF DECIMAL BAL,R13 GENDIGSF GENERATE DIGIT FIELD LI,R0 'E' AND 'E' BAL,R14 SETCHAR STW,R7 EXPSTART SAVE POSITION LW,R9 INTSIZE AI,R9 -1 GET EXPONENT SIZE BGEZ EFORM4 + LI,R0 MINUSIGN - BAL,R14 SETCHAR LAW,R9 R9 EFORM4 LI,R8 0 DW,R8 TENSTBL+1 DEVELOP 10'S VALUE BEZ EFORM5 NONE AI,R9 X'F0' GENERATE 10'S VALUE STB,R9 0,R7 AI,R7 1 EFORM5 AI,R8 X'F0' GENERATE UNIT'S VALUE STB,R8 0,R7 AI,R7 1 LW,R1 EXPSTART GET POSITION OF EXPONENT SW,R1 R7 AI,R1 3 CHECK IF BLANK FFLL NEEDED BLEZ NXPHRASE NO-EXIT LI,R14 NXPHRASE YES-SET EXIT B PUTBLNKS GENERATE BLANKS * * IFORMGEN- * FFORMGEN-PROCESSORS FOR F AND I FORMATS * * THIS ONE IS REALLY A GRINDER! * * IN ADDITION TO FORMING THE EBCDIC DIGITS IN THE FIELD * 'DECORATORS' AND 'QUALIFIERS' ARE HANDLED * THIS INCLUDES-ACCORDING TO THE OPTIONS: * LEFT OR RIGHT JUSTIFICATION * INSERTION OF DECORATORS ON LEFT OR RIGHT * INSERTION OF COMMAS ALA- 2,345,678.9012345 * BLANKING ZERO VALUES * INSERTING LEADING ZEROS * * LOCAL FIF1,FIF2,FIF3,FIF4,FIF5,FIF6,FIF7,FIF8,FIF9,FIF10 LOCAL FIF11,FIF12,FIF13,FIF14,FIF15 LOCAL FIF16,FIF17,FIF18,FIF19,FIF20 IFORMGEN BAL,R13 GETDATUM GET A VALUE CI,R5 CHAR SCRUB ON TEXT BE ERDOMAIN LW,R1 R3 GET FIELD WIDTH B FIFORMGN FFORMGEN BAL,R13 GETDATUM GET A VALUE CI,R5 CHAR SCRUB ON TEXT BE ERDOMAIN LW,R1 R3 GET FIELD WIDTH AI,R1 -1 SPACE FOR '.' SW,R1 DORS # OF FRACTIONAL DIGITS FIFORMGN CI,R10 BBIT CHECK IF 'B' OPTION SET BAZ FIF1 NO 21-00001 LW,R11 VALFLAG YES BE GAPFIELD (BLANKS OR 'R' DECORATION) FIF1 LW,R11 INTSIZE CI,R11 1 GET # OF INTEGER DIGITS OR 1 IN R11 BGE FIF2 LI,R11 1 FIF2 SW,R1 R11 ADJUST SIZE STW,R11 SAVEREAL SAVE # OF INTEGERS LW,R2 VALFLAG BGEZ FIF3 SW,R1 MLENGTH SPACE FOR M/N TEXT LENGTHS IF - SW,R1 NLENGTH (DEFAULT IS MLENGTH=1,NLENGTH=0) B FIF4 FIF3 SW,R1 PLENGTH SPACE FOR P/Q TEXT LENGTHS IF + SW,R1 QLENGTH (DEFAULT IS PLENGTH=0,QLENGTH=0) FIF4 BLZ OVERFLOW TOO DAMN BIG STW,R1 GAPSIZE OK:REMEMBER GAP SIZE LI,R2 0 STW,R2 COMMACNT SET COMMA COUNT TO ZERO CI,R10 CBIT CHECK FOR COMMAS BAZ FIF7 NO-THANK GOD! LI,R11 LBIT+ZBIT YECCH!-CHECK FOR C.AND.Z.AND.NOT.L CS,R10 BITMASK+4 (ZBIT)AND NOT L BNE FIF5 NO-HOORAY AW,R1 SAVEREAL YES-THE GAP WILL BE LEADING ZEROS SAS,R1 -2 INFESTED WITH COMMAS B FIF6 FIF5 LW,R1 SAVEREAL IN THIS CASE ONLY 1 COMMA FOR EVERY AI,R1 -1 3 INTEGER PART DIGITS DW,R1 THREE (STARTING WITH THE 4TH DIGIT) FIF6 STW,R1 COMMACNT LCW,R1 COMMACNT AWM,R1 GAPSIZE REDUCE THE GAP SIZE BLZ OVERFLOW THE COMMAS BLEW IT ! FIF7 CI,R10 LBIT+ZBIT BANZ FIF8 IF Z OR L SET,NO GAP AT LEFT BAL,R14 PUTGAP FIF8 LW,R1 VALFLAG CHECK VALUE BLZ FIF9 NEGATIVE LW,R2 PLENGTH POSITIVE BLEZ FIF11 SET PTEXT IF PRESENT (DEFAULT-NO) LW,R1 PTEXT B FIF10 FIF9 LW,R2 MLENGTH SET MTEXT IF PRESENT (DEFAULT-'-') BLEZ FIF11 LW,R1 MTEXT FIF10 BAL,R14 PUTSTRNG FIF11 STW,R7 INTLEFT SAVE POSITION OF 1ST INTEGER AW,R7 COMMACNT ADD SPACE FOR COMMAS IF PRESENT LI,R11 LBIT+ZBIT TEST FOR Z AND NOT.L CS,R10 BITMASK+4 (Z,NOT L) BNE FIF12 NO LW,R1 GAPSIZE YES BEZ FIF12 NO GAP BAL,R14 PUTZEROS GAP IS LEADING ZERO'S FIF12 LI,R1 0 STW,R1 INTRIGHT PRESET-NO INTEGER RIGHT POSITION LW,R2 NSIZE # OF CHARS IN R8-R9 TO CONVERT LW,R12 INTSIZE # OF CHARS LEFT OF '.' LW,R11 SAVEREAL AW,R11 DORS R11=# OF DIGITS TO BE GENERATED BAL,R13 GENDIGSF DO IT LW,R1 INTRIGHT CHECK IF INTRIGHT SET BNEZ FIF13 YES STW,R7 INTRIGHT NO-SET IT CI,R4 FFORMAT CHECK IF F FORMAT BNE FIF13 NO-PROCEED LW,R1 DORS YES-CHECK IF D IS ZERO BGZ FIF13 NO-PROCEED LI,R0 '.' YES-REQUIRES DECIMAL POINT BAL,R14 SETCHAR INSERTION FIF13 LW,R1 VALFLAG CHECK VALUE BLZ FIF14 NEGATIVE LW,R2 QLENGTH POSITIVE BLEZ FIF16 SET QTEXT IF PRESENT(DEFAULT-NO) LW,R1 QTEXT B FIF15 FIF14 LW,R2 NLENGTH SET NTEXT IF PRESENT(DEFAULT-NO) BLEZ FIF16 LW,R1 NTEXT FIF15 BAL,R14 PUTSTRNG FIF16 CI,R10 LBIT CHECK 'L' BAZ FIF17 NO BAL,R14 PUTGAP YES-PUT GAP HERE FIF17 CI,R10 CBIT CHECK INSANITY BAZ NXPHRASE NO-ESCAPE LCW,R9 COMMACNT YES-DRAT! BEZ NXPHRASE NO COMMAS SET-SCRAM AW,R9 INTRIGHT SW,R9 INTLEFT (INTRIGHT-INTLEFT-COMMACNT) LI,R8 0 DW,R8 THREE MODULO 3 AI,R8 0 CHECK FOR 0 BGZ FIF17A NO 21-00011 LI,R11 LBIT+ZBIT CHECK FOR (Z,NOT L) 21-00012 CS,R10 BITMASK+4 21-00013 BE FIF17A YES,COMMA MAY LEAD 21-00014 LI,R8 3 NO,ADD 3,COMMA MAY NOT LEAD 21-00015 FIF17A AW,R8 INTLEFT 21-00016 STW,R8 COMMALOC FIRST COMMA LOCATION LW,R1 INTLEFT AW,R1 COMMACNT FIRST INTEGER CHARACTER XW,R7 INTLEFT SWITCH TARGET BYTE ADDRESS AND SAVE FIF18 CW,R7 COMMALOC IS IT COMMA TIME BNE FIF19 NO-MOVE BYTES LI,R0 ',' YES STB,R0 0,R7 STASH AI,R7 1 A COMMA MTW,4 COMMALOC BUMP LOC FOR NEXT COMMA MTW,-1 COMMACNT KNOCK COUNT BLEZ FIF20 QUIT IF DONE FIF19 LB,R0 0,R1 GET A DIGIT AI,R1 1 STB,R0 0,R7 SET A DIGIT AI,R7 1 B FIF18 LOOP FIF20 LW,R7 INTLEFT RESTORE R7 TO END OF FIELD B NXPHRASE ESCAPE LOCAL PAGE * * INITFORM-INITIALIZE FORMAT (LEFT ARG) SCAN * R14=LINK * R6 IS SET AS POINTER TO FORMAT SCAN * ---R6 IS RESERVED REGISTER FOR THIS PURPOSE--- * R9 IS USED-0 RETURNED ON EXIT * RPTCOUNT SET=0 * DATASPEC SET=0 * INITFORM LW,R6 LFARG GET DB POINTER LW,R9 2,R6 AND LENGTH OF FORMAT STATEMENT SLS,R6 2 FORM BYTE ADDRESS OF FIRST FORMAT AI,R6 X'8000C' CHARACTER,SET HI-ENV NEG. FOR BIR AW,R9 R6 STW,R9 FORMLIM SET LIMIT OF SCAN (ALSO NEG. VALUE) LI,R9 0 STW,R9 RPTCOUNT INITIALIZE REPEAT COUNT STW,R9 DATASPEC AND DATA SPECIFIER FLAG B *R14 * * FPHRASE-SCAN FORMAT PHRASE * * THIS ROUTINE SCANS A FORMAT PHRASE AND RETURNS INFORMATION * FOR PROCESSING SAME: * * IF A PHRASE INCLUDES A REPEAT COUNT,SUBSEQUENT CALLS RETURN * THE SAME INFORMATION UNTIL THE REPEAT COUNT IS EXHAUSTED * * R12=LINK REGISTERS NOT TOUCHED:R1,R2,R5,R7,R8,R11,R15 * ROUTINES CALLED: * FCHAR-R0,R6,R14 * FSTRING-R0,R3,R6,R13-FCHAR * FNUM -R0,R6,R9,R13-FCHAR * ON EXIT: * R4=FORMAT TYPE 1,I 2,F 3,E 4,A 5,X 6,TEXT * R3=FIELD WIDTH * R10=QUALIFIER AND DECORATOR FLAG BITS (FORMAT I OR F ONLY) * BITS 23-31 ARE: 23 24 25 26 27 28 29 30 31 * R Q P N M Z L C B * FOR DECORATION BIT, STRING POINTERS AND LENGTHS ARE ALSO SET: * M ADDRESS IN MTEXT LENGTH IN MLENGTH * N NTEXT NLENGTH * P PTEXT PLENGTH * Q QTEXT QLENGTH * R RTEXT RLENGTH * DEFAULT STRINGS ARE ESTABLISHED FOR NON-SPECIFIED DECORATIONS * 'DORS' IS SET TO D OR S VALUE FOR F OR E FORMAT TYPE * IS SET TO ZERO FOR I FORMAT TYPE LOCAL FPH1,FPH2,FPH3,FPH4,FPH5,FPH5A,FPH6,FPH7,FPH8,FPH9 LOCAL FPH10,FPH11,FPH12,FPH13 FPHRASE MTW,-1 RPTCOUNT CHECK FOR A REPEATER BGZ *R12 GOOD-SAVED SOME TIME HERE! FPH1 BAL,R14 FCHAR START NEW SCAN FPH2 CLM,R0 LETTERS CHECK 1ST CHARACTER BCS,8 FPH4 DIGIT (OR ERROR) BCR,1 FPH5 LETTER CI,R0 QUADQUOT CHECK QUOTE-QUAD BE FPH3 -START OF SUBSTRING CI,R0 END CHECK END BNE ERFORMAT NO VALID FORM LW,R9 DATASPEC END-CHECK IF ANY DATA USE SPECIFIED BEZ ERFORMAT NONE-THATS A NO-NO CI,R12 RESWCHK CHECK IF FPHRASE CALLED FOR BE NOWRAP RESULT WIDTH CALC. QUIT IF YES CI,R12 FTYPETBL CHECK IF MAINSCAN CALL 21-00003 BNE WRAPPER WRAPAROUND IF NOT 21-00004 LW,R9 ARGCOLS CHECK IF COLUMNS OF ARG USED UP 21-00005 BDR,R9 WRAPPER NO-WRAP AROUND 21-00006 MTW,0 ARGCOUNT CHECK IF ARGUMENTS USED UP 21-00007 BLEZ ENDROW YES 21-00008 WRAPPER LW,R6 LFARG NO,ITS WRAP AROUND TIME 21-00009 SLS,R6 2 AI,R6 X'8000C' SET POINTER TO START FROM BEGINNING B FPH1 AND GO- FPH3 BAL,R13 FSTRING1 PROCESS SUBSTRING LI,R4 TFORMAT SET FORMAT TYPE -TEXT BAL,R14 FCHAR GET FIELD TERMINATOR CHARACTER B FPH13 EXIT FPH4 BAL,R13 FNUM1 THIS HAS TO BE THE REPEAT COUNT STW,R9 RPTCOUNT AI,R9 0 CHECK SIZE BGZ FPH2 OK (NEXT CHAR IS IN R0) B ERFORMAT NO DICE! FPH5 LI,R10 0 PRESET BIT FLAGS TO 0 STW,R10 DORS SET 'D OR S' TO ZERO LI,R4 RLENGTH-MTEXT+1 FPH5A LW,R9 DEFAULTS,R4 PRESET DEFAULTS FOR STW,R9 MTEXT-1,R4 MTEXT THROUGH RLENGTH BDR,R4 FPH5A FPH6 LB,R4 SPECTBL (BYTE COUNT) FPH7 CB,R0 SPECTBL,R4 CHECK CONVERSION TYPE BE FPH8 FOUND IT BDR,R4 FPH7 B ERFORMAT NONE-ERROR FPH8 CI,R4 1STQUAL CHECK IF TYPE IS QUAL OR DECOR BL FPH10 NO-CLEAN CONVERSION OR,R10 QDBITS,R4 YES-SET A FLAG BIT CI,R4 1STDECOR IS IT A DECOR BL FPH9 NO- BAL,R13 FSTRING YES-GET THE SUBSTRING LW,R9 TEXTADR STW,R9 DECORTEX,R4 STW,R3 DECORLEN,R4 FPH9 BAL,R14 FCHAR SCAN FOR NEXT FORMAT ID, QUAL B FPH6 OR DECOR. FPH10 CI,R4 FFORMAT CHECK FORMAT ID BLE FPH11 I OR F AI,R10 0 NOT I OR F-NO QUAL OR DECOR ALLOWED BNEZ ERFORMAT FPH11 BAL,R13 FNUM GET FIELD WIDTH LW,R3 R9 BLEZ ERFORMAT FIELD WIDTH MUST BE GR THAN ZERO CLM,R4 FESPEC IS THIS AN F OR E TYPE BCS,9 FPH12 NO CI,R0 '.' YES-NEED A DOT HERE BNE ERFORMAT BAD FORM BAL,R13 FNUM GET D OR S VALUE STW,R9 DORS SAVE IT CI,R4 EFORMAT CHECK IF E FORMAT BNE FPH12 NO CI,R9 0 YES-CHECK S VALUE BLE ERFORMAT MUST BE GR THAN ZERO FPH12 CI,R4 XFORMAT CHECK FOR BLANK INSERTION BE FPH13 YES-NO DATA SPEC. MTW,1 DATASPEC SET DATA SPEC. FLAG FPH13 CI,R0 ',' FORMAT PHRASE TERMINATOR BE *R12 OK CI,R0 END BE *R12 OK B ERFORMAT ERROR * * FCHAR-GET NEXT NON-BLANK FORMAT CHARACTER * IF THERE ARE NO MORE,RETURNS 'END' * R14=LINK * CHAR RETURNED IN R0 * R6,FORMAT POINTER,IS UPDATED * FCHAR CW,R6 FORMLIM CHECK FOR END BL FCHAR1 NO LI,R0 END YES B *R14 FCHAR1 LB,R0 0,R6 GET CHAR AI,R6 1 KICK POINTER CI,R0 ' ' CHECK FOR BLANK BNE *R14 NO B FCHAR YES-SKIP * * FNUM-SCAN FORMAT NUMBER * SCANS AND EVALUATES A DEC. NO. IN THE FORMAT STRING * R13=LINK * ON EXIT, R9=VALUE OF NUMBER * R0=TERMINATING CHARACTER * R6(FORMAT POINTER) UPDATED * * CALLS FCHAR,WHICH USES R0,R6,R14 * FNUM1-ENTRY USED WHEN FIRST CHARACTER ALREADY SCANNED AND IN R0 * LOCAL FNUMLOOP FNUM BAL,R14 FCHAR GET 1ST CHAR FNUM1 CLM,R0 F0F9 RANGE CHECK BCS,9 ERFORMAT NO NUMBER WHEN REQUIRED LW,R9 R0 AI,R9 -'0' SET R9=VALUE FNUMLOOP BAL,R14 FCHAR GET NEXT CHAR CLM,R0 F0F9 RANGE TEST BCS,9 *R13 DONE AI,R0 -'0' GET VALUE MI,R9 10 FORM RESULT BOV ERFORMAT TOO BIG AW,R9 R0 BNOV FNUMLOOP LOOP FOR NEXT DIGIT B ERFORMAT TOO BIG * * FSTRING-SCAN FORMAT SUBSTRING-BETWEEN QUOTE-QUADS- * R13=LINK * RETURNS BA OF 1ST CHAR. IN 'TEXTADR' * LENGTH OF STRING IN * R6 IS UPDATED TO END OF SUBSTRING+1 * FSTRING1-ENTRY FOR USE WHEN LEFT QUOTE-QUAD ALREADY SCANNED * * CALLS FCHAR, WHICH USES R0,R6, AND R14 * LOCAL FSTRING2,FSTRING3 FSTRING BAL,R14 FCHAR GET FIRST CHAR CI,R0 QUADQUOT BNE ERFORMAT MUST BE QUOTE-QUAD FSTRING1 STW,R6 TEXTADR SAVE BA OF TEXT STRING LI,R0 QUADQUOT SET TO TEST FOR END FSTRING2 CW,R6 FORMLIM CHECK OVERRUN BGE ERFORMAT YES-ERROR CB,R0 0,R6 CHECK END BE FSTRING3 YES BIR,R6 FSTRING2 NO-LOOP FSTRING3 LW,R3 R6 SW,R3 TEXTADR GET LENGTH BIR,R6 *R13 PAGE * * INITIALIZE RIGHT ARGUMENT SCAN-SET-UP FOR GETARG * R14=LINK * R1,R2,R5,R8,R9 USED * * ON EXIT: R5=DATA TYPE * LOCAL INITARG1 INITARG LI,R1 1 STW,R1 ARGCOUNT SET ARG COUNT=1 LI,R1 RTARG STW,R1 ARGADR SET ARG POINTER LB,R5 *RTARG CI,R5 LIST CHECK FOR LIST BNE INITARG1 NO-DONE! LH,R2 *RTARG YES-DAMN! AI,R2 -LIST*X'100'-1 BNEZ ERRANK RANK MUST BE 1 LW,R1 RTARG SET FOR ARGADR LW,R2 2,R1 STW,R2 ARGCOUNT ARGCOUNT=LENGTH OF LIST AI,R1 3 STW,R1 ARGADR ARG POINTER FOR 1ST ARG IN LIST INITARG1 LD,R8 ARGADR AND ARGCOUNT STD,R8 ARGWORDS SET-UP FOR 'RESETARG' B *R14 RETURN * * GETARG-GETS NEXT(OR ONLY) RIGHT ARGUMENT * RETURNS INFORMATION PERTAINING TO ARGUMENT * IF NO ARG,RETURNS TO CALL+1 * IF ARG, RETURNS TO CALL+2 * ON EXIT: R1=ARG ADDRESS * R2=RANK * R5=DATA TYPE 1 LOGL * 2 CHAR * 3 INTG * 4 FLOT * 5 INDS (INTEGER INDEX SEQUENCE) * R8=NO. OF ROWS * R9=NO. OF COLUMNS * * R14=LINK,R1,R2,R5,R8,R9 USED * * GETARG MTW,-1 ARGCOUNT CHECK AND DECREMENT ARGUMENT COUNT BLZ *R14 NONE-ZAP! LW,R1 *ARGADR GET ARG POINTER MTW,1 ARGADR KICK POINTER-POINTER LH,R2 *R1 AND,R2 XFF CI,R2 2 BG ERRANK EXU ROWSETBL,R2 EXU COLSETBL,R2 LB,R5 *R1 AI,R14 1 B *R14 * ROWSETBL LI,R8 1 SCALAR LW,R8 2,R1 VECTOR LW,R8 2,R1 ARRAY COLSETBL LI,R9 1 SCALAR LI,R9 1 VECTOR LW,R9 3,R1 ARRAY * * INITDATA-INITIALIZES PARAMETERS USED BY 'GETDATUM' * * R14=LINK R8,R9 USED * INITDATA LI,R8 0 STW,R8 ROWINDEX ROW INDEX=0 STW,R8 ARGCOLS SIMULATE 'LAST COLUMN' CONDITION LD,R8 ARGWORDS INITIALIZE ARG ADR AND COUNT STD,R8 ARGADR AND ARGCOUNT B *R14 * * GETDATUM-GET A SINGLE ELEMENT (OR NULL) FROM AN ARGUMENT * DATA ARE ACCESSED COLUMN BY COLUMN (FOR MATRICES) * THEN ADVANCE TO COLUMN 1 OF NEXT ARGUMENT * * R13=LINK CALLS:GETARG-WHICH USES R1,R2,R5,R8,R9 AND R14 * PLUSREAL-WHICH USES R2,R5,R8,R9,AND R12 * (R5 IS SAVED AND RESTORED) * * ON EXIT,R5=TYPE 1=LOGL 2=CHAR 3=INTG 4=FLOT * * IF CHAR, VALUE IS IN R8 * IF LOGL,INTG,OR FLOT,RESULT IS: * VALUE AS LONG INTEGER IN R8-R9 * TOTAL # OF IDGITS (MAX=16) IN NSIZE * # OF INTEGER DIGITS IN INTSIZE * * IF THE CURRENT ARGUMENT HAS FEWER ROWS THAN CURRENT ROW INDEX * EXIT TO XFORMGEN-GENERATE BLANK FIELD * LOCAL GETD1,GETD2,GETD3,GETD4,GETD5,GETD6,GETD7 LOCAL GETD8,GETD9,GETD10 GETDATUM MTW,-1 ARGCOLS ANY MORE COLUMNS IN THIS ARG BGZ GETD4 YES-EASY BAL,R14 GETARG NO-NEXT ARGUMENT B ENDROW NO MORE ARG'S THIS ROW STD,R8 ARGROWS AND ARGCOLS CW,R8 ROWINDEX IF ROWINDEX > ARGROWS BL GETD5 THIS IS NULL CI,R5 INDSEQ CHECK FOR INDEX SEQ BE GETD2 YES-SPECIAL CASE MW,R9 ROWINDEX COMPUTE OFFSET (IN ELEMENTS) SW,R9 ARGCOLS TO DESIRED ELEMENT AW,R1 R2 ADD # OF LENGTH WORDS TO DB POINTER AI,R1 2 OFFSET 2 HDR WORDS-POINT TO DATA EXU SETDATBL,R5 CONVERT TO 1ST ELEMENT ADDRESS GETD1 AW,R1 R9 OFFSET TO DESIRED ELEMENT STW,R1 DATALOC THAT'S IT! B GETD7 GETD2 LW,R9 4,R1 'B' MW,R9 ROWINDEX 'B'*'I' AW,R9 3,R1 +'A' LW,R8 R9 VALUE FOR IND SEQ ELEMENT LI,R5 INTG FAKE INTEGER DATA TYPE SETDATBL B CONVINT CONVERT INTEGER DATA TYPE @@@@@@@ B GETD3 LOGIC-YIKES! @ SLS,R1 2 TEXT- SHIFT @ NOP INTG-LEAVE ALONE @ B %+1 FLOT- @ AI,R1 1 INSURE DW-BOUND @ SLS,R1 -1 SHIFT TO DW ADDRESS @ B GETD1 CONTINUE @@@@@@@ GETD3 LI,R2 X'1F' LOGICAL DATA:SEPARATE OFFSET INTO AND,R2 R9 WORD OFFSET-R9 SLS,R9 -5 BIT # -R2 LW,R8 *R9,R1 GET WORD SLS,R8 0,R2 POSITION TO BIT 0 STW,R8 LOGLBITS SAVE VALUE (32 OF 'EM) EOR,R2 X1F AI,R2 1 STW,R2 LOGLCNT LOGLCNT=32-BIT # B GETD1 GETD4 LW,R8 ROWINDEX CHECK IF ARG HAS THIS MANY ROWS CW,R8 ARGROWS BLE GETD6 YES GETD5 B XFORMGEN EXIT-GENERATE BLANKS GETD6 LW,R1 DATALOC GET ELEMENT ADDRESS GETD7 EXU GETDATBL,R5 GET ELEMENT MTW,1 DATALOC BUMP ELEMENT ADDRESS GETDATBL B CONVRTR CONVERT DATUM @@@@@@@ B GETD8 LOGIC-YECH! @ B GETD11 TEXT @ LW,R8 0,R1 INTG @ LD,R8 0,R1 FLOT @@@@@@@ GETD8 MTW,-1 LOGLCNT LOGIC VALUE:ANY MORE BITS BGEZ GETD9 YES LI,R9 31 NOT IN THIS WORD STW,R9 LOGLCNT RESET COUNTER LW,R8 1,R1 GET NEXT WORD MTW,1 DATALOC KICK ELEMENT ADDRESS B GETD10 SKIP GETD9 LW,R8 LOGLBITS GET CURRENT WORD GETD10 SCS,R8 1 CYCLE STW,R8 LOGLBITS USE A BIT AND,R8 ONE MASK IT CONVLGL STW,R8 VALFLAG SAVE SIGN-ZERO FLAG LW,R9 R8 SET VALUE IN R9 LI,R8 1 CONVIORL STW,R8 INTSIZE SET INTEGER SIZE STW,R8 NSIZE SET NUMBER SIZE LI,R8 0 B *R13 CONVINT STW,R8 VALFLAG SAVE SIGN-ZERO FLAG LAW,R9 R8 GET ABS VALUE IN R9 LI,R2 -9 CONVINT1 CW,R9 TENSTBL+10,R2 RANGE TEST BL CONVINT2 SIZE FOUND BIR,R2 CONVINT1 CONVINT2 AI,R2 10 INTSIZE LW,R8 R2 CI,R13 EFORMGEN+1 CHECK IF E FORMAT BNE CONVIORL NO-OK SW,R2 DORS YES-CHECK IF INT. MUST BE ROUNDED BLEZ CONVIORL NO LW,R2 TENSTBL,R2 YES-GET POWER OF 10 SLS,R2 -1 DIVIDE BY 2 AW,R9 R2 ROUND LW,R2 R8 RESTORE INTSIZE CW,R9 TENSTBL,R2 CHECK FOR OVERFLOW BY ROUND BL CONVIORL NO AI,R8 1 YES-KICK INTSIZE B CONVIORL CONVRTR CI,R5 FLOT CHECK DATA TYPE (REAL OR INTEGER) BNE CONVINT INTEGER STW,R8 VALFLAG REAL LAD,R8 R8 SET + VALUE BEZ CONVLGL QUICK EXIT IF ZERO CI,R13 EFORMGEN+1 CHECK E FORMAT BE CONVRL1 YES-ROUNDOFF IS FIXED BY DORS STD,R8 SAVEREAL NO-SAVE VALUE BAL,R11 PLUSREAL CONVERT TO GET DECIMAL EXPONENT LW,R5 R12 CALCULATE NSIZE AW,R5 DORS BLZ CONVRL5 ANOTHER ZERO CASE BEZ CONVRLH 0 TO 1,SPECIAL CASE. U21-0024 CI,R5 FLOT CHECK FOR COINCIDENT CORRECT CONV. BE CONVRL4 YES LD,R8 SAVEREAL NO-RESTORE UNCONVERTED VALUE B CONVRL2 CONTINUE CONVERSION CONVRLH LD,R8 SAVEREAL RESTORE UNCONVERTED VALUE U21-0026 FAL,R8 FLHALF ROUND IT U21-0027 FAL,R8 X4E1 FIX U21-0028 SW,R8 X4E1 IT U21-0029 LI,R5 1 SET NSIZE TO 1 U21-0030 LI,R12 1 SET INTSIZE TO 1 U21-0031 AI,R9 0 CHECK IF ZERO U21-0032 BNEZ CONVRL4 NO-OK U21-0033 STW,R9 VALFLAG YES-SET VALUE FLAG U21-0034 B CONVRL4 U21-0035 CONVRL1 LW,R5 DORS E-FORMAT, NSIZE=DORS CONVRL2 CI,R5 16 CHECK MAXIMUM NSIZE BLE CONVRL3 NO LI,R5 16 YES-USE 16 MAX CONVRL3 BAL,R11 PLUSREAL CONVERT CONVRL4 STW,R5 NSIZE SAVE NSIZE STW,R12 INTSIZE AND INTSIZE LI,R5 FLOT RESTORE R5 B *R13 EXIT CONVRL5 LD,R8 ZEROZERO LOW VALUE-SET ZERO LI,R5 FLOT RESET R5 B CONVLGL GETD11 LB,R8 0,R1 TEXT MTW,1 DATALOC UPDATE DATA LOCATION B *R13 EXIT * * PUTSTRNG-STUFF A TEXT STRING * R2=COUNT R0 USED INTERNALLY * R1=BA(TEXT) * R14=LINK * R7=BA CURRENT RESULT * PUTSTRNG LB,R0 0,R1 STB,R0 0,R7 AI,R7 1 AI,R1 1 BDR,R2 PUTSTRNG B *R14 * * PUTBLNKS-STUFF N BLANKS R1=N * R14=LINK R0 USED INTERNALLY * R7=BA CURRENT RESULT PUTBLNKS LI,R0 ' ' PUTIT STB,R0 0,R7 AI,R7 1 BDR,R1 PUTIT B *R14 * * PUTZEROS-STUFF N ZEROS R1=N * PUTZEROS LI,R0 '0' B PUTIT * * PUTGAP-FILLS GAP WITH BLANKS,OR,IF RBIT SET, WITH 'RTEXT' * IF USED, 'RTEXT' IS REPEATED AS REQUIRED TO FILL THE GAP * * R14=LINK R0,R1,R2,R7,R11 USED * LOCAL PUTGAP1,PUTGAP2,PUTGAP3 GAPFIELD CI,R10 RBIT CHECK IF 'R' SET BAZ XFORMGEN NO-EASY OUT STW,R3 GAPSIZE YES-GAPSIZE=FIELD WIDTH LI,R14 NXPHRASE EXIT TO NXPHRASE PUTGAP LW,R1 GAPSIZE GET GAPSIZE BLEZ *R14 EMPTY GAP CI,R10 RBIT CHECK IF RBIT IS SET BAZ PUTBLNKS NO B PUTGAP2 ENTER LOOP PUTGAP1 BDR,R11 PUTGAP3 DECREMENT R-COUNT,SKIP IF NOT DONE PUTGAP2 LW,R11 RLENGTH R-COUNT LW,R2 RTEXT R-ADDRESS PUTGAP3 LB,R0 0,R2 GET 'R' BYTE STB,R0 0,R7 STASH IT AI,R7 1 UPDATE AI,R2 1 POINTERS BDR,R1 PUTGAP1 DECREMENT GAP COUNT-LOOP IF NOT DONE B *R14 * * OVERFLOW-REACHED FROM E-F-OR I FORMAT GEN IF CONVERSION WON'T FIT * R3=FIELD WIDTH * EXIT TO NXPHRASE OVERFLOW LI,R0 '*' OVERFLOW CHARACTER LW,R1 R3 WIDTH LI,R14 NXPHRASE EXIT LOC B PUTIT ENTER LOOP * * GENDIGSF-ROUTINE TO GENERATE DIGITS FOR DELTAFMT * * R13=LINK * * ON ENTRY R2=# OF DIGITS IN R8-R9 VALUE TO BE CONVERTED * R11=# OF DIGITS+UNDERSCORES OR BLANKS TO BE GENERATED * R12=# OF DIGITS LEFT OF DECIMAL * R8-R9=VALUE TO BE CONVERTED * R7= BA TO STORE DIGITS * * REGISTERS NOT USED:R3(W) R4(FORMAT TYPE)R5(DATUM TYPE) * R6(FORMAT POINTER)R10(FLAG BITS) * * REGISTERS USED AND VOLATILE:R0,R1,R2,R8,R9,R11,R12,R14 * * ON EXIT R7= BA FOR NEXT FIELD ITEM * LOCAL GENDIG0,GENDIG1,GENDIG2,GENDIG3,GENDIG4,GENDIG5 LOCAL GENDIG6,GENDIG7,GENDIG8,GENDIG9,GENDIG10,GENDIG11 LOCAL GENDIG12,GENDIG13,GENDIG14,GENDIG15 GENDIGSF AI,R12 0 TEST 'INTSIZE' BGZ GENDIG4 INTEGER CHARS EXIST BAL,R14 SETZER NO INTEGER CHARS-INSERT 0 STW,R7 INTRIGHT SAVE END OF INTEGER POSITION LI,R14 GENDIG1 GENDIG0 LI,R0 '.' BDR,R11 SETCHAR F OR E FORMAT BRANCHES B *R13 I FORMAT EXIT FOR 0 GENDIG1 AI,R12 0 CHECK FOR FRACT. WITH LEADING ZEROS BEZ GENDIG4 NO LI,R14 GENDIG3 YES AI,R12 -1 ADJUST COUNT FOR BIR LOOP GENDIG2 BIR,R12 SETZER SET ZEROS B GENDIG4 GENDIG3 BDR,R11 GENDIG2 DECREMENT 'TSIZE' FOR EACH ZERO B *R13 EXIT IF TSIZE REACHED GENDIG4 LI,R1 0 STW,R1 LDFLAG RESET LONG-DIVIDE FLAG LI,R1 16 SET SIGNIFICANCE COUNT CI,R2 10 CHECK MSIZE BLE GENDIG6 SHORT DIVIDE MTW,1 LDFLAG LONG DIVIDE-SET FLAG DW,R8 TENSTBL+9 DIVIDE STW,R8 LOWEND SAVE LOW END AI,R2 -9 ADJUST DIVIDE INDEX GENDIG5 LI,R8 0 SET FOR DIVIDE GENDIG6 DW,R8 TENSTBL-1,R2 DIVIDE OUT A DIGIT XW,R8 R9 AI,R8 X'F0' FORM EBCDIC CHAR STB,R8 0,R7 STASH IT AI,R7 1 AI,R1 -1 DECREMENT SIGNIFICANCE COUNT BDR,R11 GENDIG7 DECREMENT CHAR COUNT B *R13 EXIT IF DONE GENDIG7 AI,R12 -1 DECREMENT DECIMAL POSITION BNEZ GENDIG8 NOT TIME FOR '.' STW,R7 INTRIGHT TIME FOR '.'-SAVE POSITION LI,R0 '.' BAL,R14 SETCHAR SET '.' GENDIG8 BDR,R2 GENDIG5 LOOP MTW,-1 LDFLAG CHECK LONG-DIVIDE FLAG AND RESET BLZ GENDIG9 SHORT DIVIDE(OR 2ND LOOP DONE) LI,R2 9 SETUP FOR 2ND LOOP LW,R9 LOWEND GET LOW END OF VALUE B GENDIG5 DO 2ND LOOP GENDIG9 LI,R14 GENDIG10 STUPID LONG FIELD CASE! GENDIG10 AI,R12 -1 ADJUST AND TEST DECIMAL POSITION BGZ GENDIG13 INTEGERS LEFT BLZ GENDIG15 FRACTION LEFT LI,R14 GENDIG12 AT '.' POINT GENDIG11 AI,R1 -1 DECREMENT SIGNIFICANCE AND TEST BGEZ SETZER OK-GEN ZERO LI,R0 UNDRSCOR 16+ GEN UNDERSCORE B SETCHAR GENDIG12 LI,R14 GENDIG10 GENERATE '.' B GENDIG0 OR QUIT IF I FORMAT GENDIG13 LI,R14 GENDIG14 B GENDIG11 GENDIG14 BDR,R11 GENDIG10 B *R13 GENDIG15 XW,R11 R1 SWITCH TSIZE AND SIGNIF. COUNT LW,R14 R13 SET EXIT AI,R11 0 CHECK IF SIG. CHARS. REMAIN BLEZ PUTBLNKS NO-PUT ALL BLANKS CW,R1 R11 CHECK IF SIG CHARS EXCEED TSIZE BLE PUTZEROS YES-PUT ALL ZEROS XW,R1 R11 NO-MIXED BAG SW,R11 R1 SAVE BLANK COUNT IN R11 BAL,R14 PUTZEROS PUT SOME ZEROS B GENDIG15 R1=0 HERE-NEXT PASS PUTS THE BLANKS SETZER LI,R0 X'F0' SETCHAR STB,R0 0,R7 SET A CHARACTER AI,R7 1 B *R14 LOCAL END