/BCDASC CONVERSION ROUTINE /MODIFICATION HISTORY / /015 KMD 23-Sep-85 Dutch Xlations /014 KMD 13-Sep-85 Norway & Sweeden specific. (esp. CS3CHR defs) /013 KMD 10-Sep-85 Allow Post-digit (esp. Spanish) currency symb. /012 KMD 02-AUG-85 Allow non-american seperators in results /011 RCME 18-APR-85 Allow tech and multinational characters in / field names for list processing / /---------------------- all below refer to V2.0 and earlier ------------------ / /010 JFS 11-JUN-84 Am/Brit currency modifications /009 JRF 30-OCT-81 MOVED BCDASC PAGE 0 EQUATES TO M.PA /008 DAO 25-OCT-81 REMOVED CHKNME ROUTINE TO EDITOR WHERE THERE / IS MORE ROOM / AND ADDED CODE TO COUNT NUMBER OF CHARACTERS / OUTPUT AND PUT IN MQ / CHANGED ALL ".-200 TO RADIX TO HELP FOREIGN /007 JRF 20-OCT-81 Delete DCHAR and TCHAR and put in WPEDIT /006 JRF 19-OCT-81 Label "*UN.DEF*" and "*OVR.FLO*" text strings. /005 DAO 16-OCT-81 Changed where BCDASC assembles /004 DRH 01-OCT-81 PUT FIXES INTO "CHKNME" /003 DAO 25-SEP-81 ADDED CHKNME ROUTINE /002 DAO 24-SEP-81 SHRUNK TO 3 PAGES (FROM 4) /001 DAO CREATED /PSUEDO-CODE /VARIABLES / LFTNUM: # OF DIGITS TO LEFT OF RADIX WITH LEADING 0 SUPPRESSION / / RGTNUM: # OF DIGITS TO RIGHT OF RADIX WITH TRAILING ZERO SUPPRESSION / / SGN: SIGN OF NUMBER, 0=POSATIVE, 1=NEGATIVE / / RGTFOR: #DIGITS IN FORMAT TO RIGHT OF RADIX / / LFTFOR: #DIGITS IN FORMAT TO LEFT OF RADIX / / NONZR0: NON ZERO FLAG. 0=NUMBER CONTAINS ONLY ZEROES, / OTHERWISE # CONTAINS NON ZERO DIGITS / / NUMCOM: NUMBER OF COMMAS IN LARGEST NUMBER POSSIBLE WITH THIS FORMAT / MINUS NUMBER OF COMMAS ACTUALLY OUTPUT / IF COMMA-BIT SET / THEN NUMCOM=INT[(LFTFOR-1)/3]-INT[(LFTNUM-1)/3] / ELSE NUMCOM=0 / / NUMAST: NUMBER OF ASTERISKS TO OUTPUT BEFORE WHOLE DIGITS / IF ASTERISK-BIT SET / THEN NUMAST=(LFTFOR+NUMCOM)-LFTNUM / / CHRCNT: POINTS TO EITHER CHRRGT OR CHRLFT AND IS USED TO COUNT / NUMBER OF ASCII CHARACTERS OUTPUT TO LEFT AND TO RIGHT / OF THE DECIMAL POINT. / / CHRLFT: NUMBER OF CHARACTERS OUTPUT TO LEFT OF FIRST DECIMAL POINT / OR LEFT PAREN / / CHRRGT: NUMBER OF CHARACTERS OUTPUT TO RIGHT OF FIRST DECIMAL POINT / OR LEFT PAREN INCLUDING THE DECIMAL POINT OR RIGHT PAREN /IF UNDEFINED BIT SET / THEN OUTPUT "*Un.def*" / ELSE / IF OVERFLOW BIT SET / THEN OUTPUT "*Ovr.flo*" / ELSE / SCAN_BCD / / IF (NOT DEFAULT) AND (LFTNUM > LFTFOR) / THEN TURN OFF ASTERISK BIT / OUTPUT "%" / / IF NEGATIVE THEN / CASE SIGN-FORMAT OF: / LEADING: OUTPUT "-" / PARENS: OUTPUT "(" / TRAILING: DO-NOTHING / / IF CURRENCY INDICATOR SET / THEN OUTPUT "$" (OR APPROPRIATE INTERNATIONAL CURRENCY SIGN) / / IF ASTERISK-BIT SET / THEN FOR I=1 T0 NUMAST / OUTPUT "*" / / (* NOW OUTPUT WHOLE DIGITS USING OUTPUT ROUTINE WHICH WILL / AUTOMATICALLY PUT IN THE COMMAS IF APPROPRIATE *) / / FOR I=1 TO LFTNUM / CALL DIGOUT / / (* NOW HANDLE DECIMAL POINT AND DIGITS TO RIGHT OF RADIX / / IF DEFAULT_FORMAT / / (* THIS HANDLE DECIMAL POINT IN CASE OF DEFAULT FORMAT *) / IF (RGTNUM .NE. 0) / THEN OUTPUT RADIX / / (* THIS HANDLE DIGITS TO RIGHT OF RADIX *) / FOR I=1 TO RGTNUM / CALL DIGOUT / / ELSE (* NOT DEFAULT_FORMAT *) / / (* THIS HANDLES RADIX POINT IN NON_DEFAULT CAST *) / IF (RGTFOR .NE. 0) / THEN OUTPUT RADIX / / (* NOW DECREMENT RGTFOR SINCE IT WAS OFFSET BY ONE / SO 1 INDICATED RADIX POINT BUT NO DIGITS *) / RGTFOR = RGTFOR - 1 / / (* OUTPUT NUMBER OF DIGITS ASKED FOR *) / FOR I=1 TO RGTFOR / CALL DIGOUT / / (* NOW TAKE CARE OF TRAILING MINUS OR ')' *) / IF NEGATIVE / THEN CASE SIGN-FORMAT OF: / LEADING: DO-NOTHING / PARENS: OUTPUT ")" / TRAILING: OUTPUT "-" / / / PROCEDURE SCAN / CONSTANTS / DIGCNT=17 DECIMAL / NUMBER OF DIGITS, INCLUDING RADIX, IN PACKED BCD *) / MAXDIG=13 DECIMAL / MAXIMUM NUMBER OF DIGITS TO DISPLAY / MAXRGT=6 DECIMAL / MAXIMUM NUMBER OF DIGITS TO RIGHT OF DECIMAL / / VARIABLES / DIGOUT: / NUMBER OF DIGITS OUTPUT TO SIMPLE ASCII BUFFER / ZERSUP: / NUMBER OF TRAILING ZEROS OUTPUT / ASCBUF: / ARRAY (13 DECIMAL LONG) OF ASCII DIGITS / / INITIALIZE ASCBUF TO ALL ZEROES / / (* FIRST GET RID OF LEADING ZEROS*) / REPEAT / GETDIG / UNTIL (DIG .NE. "0") OR END_OF_BCD / / IF (DIG .EQ. RADIX) / THEN (* MEANS THERE WERE NO LEADING DIGITS SO WE MUST / OUTPUT A LEADING ZERO *) / OUTPUT("0") / DIGOUT = DIGOUT + 1 / LFTNUM = LFTNUM + 1 / ELSE (* TAKE CARE OF LEADING DIGITS *) / WHILE (DIG .NE. RADIX) AND NOT END_OF_BCD / OUTPUT(DIG) / DIGOUT = DIGOUT + 1 / LFTNUM = LFTNUM + 1 / GETDIG / END_WHILE / / / RGTNUM = 0 (* INITIALIZE NUMBER OF DIGITS TO RIGHT *) / RGTOUT = 0 (* INITIALIZE COUNTER OF NUMBER OF DIGITS TO RIGHT / OF RADIX, INCLUDING TRAILING ZEROS *) / LOOP / GETDIG (* LAST DIGIT WAS RADIX SO GET A NEW ONE *) / EXIT IF END_OF_BCD / OUTPUT(DIG) / DIGOUT=DIGOUT+1 / RGTOUT=RGTOUT+1 / IF (DIG .NE. "0") / THEN RGTNUM=RGTOUT (* NO MORE TRAILING ZEROS *) / EXIT IF (DIGOUT=MAXDIG) OR (RGTOUT=MAXRGT) / END_LOOP / / /GET PASSED PARAMETERS FROM CALLER /CALLING SEQUENCE: / /CALL: JMS BCDASC /ARG1: INPUT BCD TABLE POINTER /ARG2: DESTINATION ASCII BUFFER POINTER /ARG3: CDF TO ASCII BUFFER / /RETURN: AC=POINTER TO END OF OUTPUT BUFFER CDFMYF=CDFLP / SET CDFMYF TO CDF LIST PROCESSING FIELD / FORMAt_Word bit assignments: /ASTBIT=4000 / ASTerisk_BIT in FORMAt_Word /CURBIT=2000 / CURrency_BIT in FORMAt_Word /SEPBIT=1000 / SEParator_BIT in FORMAt_Word /PARESN=60 / PAREnthetical_minus_SigN /TRAISN=40 / TRAIling_minus_SigN /LEADSN=20 / LEADing_minus_SigN *400 FIELD 3 /ASSEMBLE IN FIELD 3 (LOADS IN FIELD 5) /D009 *BCDASC / BCDASC IS DEFINED IN WPF1.PA /M005 XX /ROUTINE STARTS HERE /M005 CLA CLL RDF /WHERE DID WE COME FROM ? TAD CIDF0 /MAKE A RETURN INSTRUCTION DCA RTN /PLACE IT IN LINE TAD I BCDASC /DF=CALLING FIELD (IF=THIS FIELS VIA JMS) DCA BCDPNT /PASSED PARAMETER=BCD BUFFER POINTER ISZ BCDASC /BUMP TO NEXT PARAMETER TAD I BCDASC /GET ASCII OUTPUT BUFFER POINTER DCA ASCPNT /READY POINTER ISZ BCDASC /BUMP TO NEXT DATA TAD I BCDASC /GET FIELD OF ASCII OUTPUT BUFFER CDFMYF / CHANGE TO MY FIELD DCA CDFA /PUT IN LINE WHERE NEEDED ISZ BCDASC /BUMP TO CORRECT RETURN POSITION DCA NEXTC / INITIALIZE NUMBER OF DIGITS TO OUTPUT BEFORE / NEXT COMMA TO 7777 (NO COMMAS WANTED) DCA CHRRGT / INITIAL CHRRGT /A008 DCA CHRLFT / INITIAL CHRLFT /A008 TAD (CHRLFT / INITIAL CHRCNT TO POINT TO NUMBER OF /A008 DCA CHRCNT / CHARACTERS TO LEFT OF RADIX OUTPUT /A008 /PARSE THE FORMAT WORD AND SET UP: / LFTFOR: NUMBER OF DIGITS REQUESTED TO LEFT OF RADIX / RGTFOR: NUMBER OF DIGITS REQUESTED TO RIGHT OF RADIX PRSFRM, JMS GETBCD / DCA FRMMAT /INITIALIZE FORMAT WORD ISZ BCDPNT /POINT TO FIRST WORD OF BCD VALUE TAD FRMMAT /GET FORMAT WORD AND (0017 /MASK OUT BITS FOR LFTFOR DCA LFTFOR /AND PUT INTO PLACE TAD FRMMAT /GET FRMMAT WORD AGAIN BSW AND (0007 /MASK OUT BITS FOR RGTFOR DCA RGTFOR /AND PUT INTO PLACE DCA DEFAUL / INITIALIZE DEFUALT FLAG TO NOT DEFAULT TAD RGTFOR / TAD LFTFOR SZA CLA / IF DEFAULT JMP PRSFR1 / THEN ISZ DEFAUL / SET DEFAULT FLAG TAD (MAXRGT+1 / DCA RGTFOR / SET NUMBER TO RIGHT OF FORMAT TO MAXIMUM /THIS IS THE FORMAT OF THE LEFT FOUR BITS OF THE FIRST WORD OF BCD VALUE /UNLIKE THE REST OF THE BCD VALUE, THESE FOUR BIT ARE RESERVED FOR FLAGS /BCD-FLAG STRUCTURE: / / +------------+------------+------------+------------+-------- - - / | BIT-0 | BIT-1 | BIT-2 | BIT-3 | / +------------+------------+------------+------------+-------- - - / | | | | | / | SIGN | INIT-ERROR | OVERFLOW | NOT USED | FIRST 2 / | | | ERROR | | DIGITS OF / | | | | | BCD VALUE --> / | 0=PLUS | 0=OKAY | 0=OKAY | | / | 1=MINUS | 1=ERROR | 1=OVERFLOW | | / | | | | | / +------------+------------+------------+------------+-------- - - /NOW TEST FOR UNDEFINED OR OVERFLOW ERRORS PRSFR1, JMS GETBCD /GET FIRST WORD OF VALUE WHICH HAS UNDEFINED BIT /AND OVERFLOW BIT RTL /LINK=UNINITIALIZED BIT SIGN=OVERFLOW BIT SZL /IF UNDIFINED BIT SET JMP INITER / THEN OUTPUT '*Un.def*' SPA CLA / ELSE IF OVERFLOW BIT SET JMP OVRFLO / THEN OUTPUT '*Ovr.flo*' /ONLY GET THIS FAR IF NO OVERFLOW OR UNDEFINED ERROR JMS GETBCD /GET FIRST WORD OF VALUE AGAIN DCA SGN /SET UP SIGN OF VALUE IN SGN /IF THIS VALUE IS NEGATIVE, IT MAY BE SET TO /POSATIVE LATER IF VALUE IS FOUND TO BE ZERO JMS SCNBCD / SCAN THE BCD WORD INTO AN ASCII STRING AT / ASCBUF, STRIPPING TRAILING AND LEADING ZEROES / AND OUTPUT "%" IF DISPLAY OVERFLOW TAD SGN / GET SIGN OF VALUE /A010 SMA CLA / IF VALUE IS NEGATIVE /A010 JMP PRSF10 /A010 JMS TSTSGN / TEST FORMAT OF SIGN INDICATOR TAD ("--"( / HERE IF LEADING (OUTPUT '-') SKP / HERE IF PARENS (OUTPUT '(') JMP PRSF10 / HERE IF TRAILING (DO NOTHING) /A010 TAD ("(-200 JMS STIKIT / OUTPUT '(' OR '-' PRSF10, IFDEF PRECUR < /IF PRE-DIGIT CS /A013 /OUTPUT CURRENCY SYMBOL, MAYBE /A010 TAD FRMMAT / GET FORMAT WORD AND (CURBIT / MASK OUT ALL BUT CURRENCY BIT SNA CLA / IF CURRENCY BIT SET JMP PRSF20 /A010 IFNDEF CS3CHR < /IF NOT 3 CHARACTER CURRENCY SYMBOL /A014 CDFMNU / OUTPUT CURRENCY SYMBOL /A010 AC0004 / WHICH ONE? /A010 AND MUBUF+MNFMAT /A010 CDFMYF /A010 SZA CLA / 0 IF Am. /A010 AC7777 / #0 IF Brit.; put -1 in AC /A010 > /END IFNDEF CS3CHR /A014 TAD (CURENC JMS STIKIT IFDEF CS3CHR < /IF 3 CHARACTER CURRENCY SYMBOL, GO GET THE REST OF IT /A014 TAD (CUREN2 / " JMS STIKIT / " TAD (CUREN3 / " JMS STIKIT / " > /END IFDEF CS3CHR /A014 > /END IFDEF PRECUR /A013 PRSF20, /OUTPUT VALUE /A010 JMS RSTOUT /A010 FINI, TAD CHRLFT / PUT CHRLFT IN LEFT 6 BITS OF MQ /A008 BSW /A008 TAD CHRRGT / PUT CHRRGT IN RIGHT 6 BITS OF MQ /A008 MQL /A008 TAD ASCPNT / GET POINTER TO TAIL OF RESULTS BUFFER RTN, 0000 /RETURN CDF CIF GOES HERE JMP I BCDASC /*** RETURN ... FINISHED / IF (NOT DEFAULT) AND (LFTNUM > LFTFOR) / THEN TURN OFF ASTERISK BIT / OUTPUT "%" CHKDEF, XX TAD DEFAUL / SZA CLA / IF NOT DEFAULT JMP I CHKDEF / TAD LFTNUM / THEN GET NUMBER OF DIGITS TO LEFT OF NUMBER CIA / AC=-LFTNUM TAD LFTFOR / AC= LFTFOR-LFTNUM SMA CLA / IF (LFTNUM .GT. LFTFOR) JMP I CHKDEF / THEN ISZ DEFAUL / TURN ON DEFUALT FLAG DCA FRMMAT / TURN OFF COMMA BIT,CURRENCY BIT, ASTERISK BIT / ETC. IN FORMAT WORD TAD ("%-200 / JMS STIKIT / OUTPUT ("%") JMP I CHKDEF / END_CHKDEF /PASS RESULTANT FINAL ASCII TO DESTINATION BUFFER /A002 STIKIT, XX CDFA, 0 /HOLDS CDF TO DESTINATION FIELD DCA I ASCPNT /OUTPUT ASCII INTO BUFFER CDFMYF /CDF BACK TO MY FIELD TAD I ASCPNT /GET CHAR BACK /A008 TAD (-RADIX /IF CHAR = RADIX /A008 SZA / /A008 TAD (RADIX-")) / OR CHAR = RIGHT PAREN /A008 SZA CLA / /A008 JMP STIK1 / /A008 TAD (CHRRGT /THEN /A008 DCA CHRCNT / HAVE CHRCNT POINT TO COUNT OF DIGIT TO /A008 / RIGHT OF RADIX OR RIGHT PAREN /A008 STIK1, ISZ I CHRCNT / INCREMENT NUMBER OF CHARACTERS OUTPUT TO LEFT /A008 / OR RIGHT OF FIRST DECIMAL OR RIGHT PAREN /A008 ISZ ASCPNT /BUMP POINTER FOR NEXT TIME JMP I STIKIT /RETURN IFDEF PSTCUR < /THIS ROUTINE IS HERE IF POST-DIGIT CS IS DEFINED OR ON THE /A013 / NEXT PAGE IF PRE-DIGIT CS IS DEFINED /A013 /THIS SUBROUTINE WILL TEST THE FORMAT OF THE SIGN /JMS TSTSGN / LEADING "-" RETURN / PARENS RETURN / TRAILING "-" RETURN TSTSGN, XX /TEST SIGN BIT IN FORMAT WORD TAD FRMMAT AND (0060 /MASK OFF SIGN BITS BSW /MOVE BITS OVER RAL /TO LINK AND BIT 8E-0 SNL /TEST LINK JMP TST1 /LINK=0=LEADING SIGN SMA CLA /EITHER TRAILING OR () ISZ TSTSGN / TRAILING ISZ TSTSGN / () TST1, CLA JMP I TSTSGN /RETURN > / END IFDEF PSTCUR PAGE RSTOUT, XX /PUT OUT REST OF VALUE AFTER SIGN, CURRENCY /A010 / FIRST CALCULATE HOW MANY ASTERISKS TO OUTPUT BEFORE THE DIGITS /NUMCOM: NUMBER OF COMMAS IN LARGEST NUMBER POSSIBLE WITH THIS FORMAT / IF COMMA-BIT SET / THEN NUMCOM=INT[(LFTFOR-1)/3]-INT[(LFTNUM-1)/3] / ELSE NUMCOM=0 DCA NUMCOM / INITIALIZE NUMBER OF COMMAS TO 0 TAD FRMMAT / GET FORMAT WORD RTL / PUT SEPERATOR BIT INTO SIGN POSITION SMA CLA / IS COMMA BIT SET? JMP AST3 / NO, SO NUMCOM=0 GO CALCULATE NUMAST DCA T1 / YES, SO CALCULATE NUMCOM=(LFTFOR-1)/3 AC7777 / TAD LFTFOR / AC = LFTFOR-1 JMS DVBY3 / T1=INT[(LFTFOR-1)/3] CLA / CLEAR REMANDER FROM DIVIDE TAD T1 / AC = INT[(LFTFOR-1)/3] DCA NUMCOM / NUMCOM = INT[(LFTFOR-1)/3] DCA T1 / INITIALIZE T1 AC7777 / AC=-1 TAD LFTNUM / AC=LFTNUM-1 JMS DVBY3 / T1=INT[(LFTNUM-1)/3] TAD (4 / USE REMANDER TO FIGURE OUT HOW MANY DIGITS CIA / TO OUTPUT BEFORE THE FIRST COMMA DCA NEXTC / NEXTC = -NUMBER OF DIGITS TO OUTPUT / BEFORE NEXT COMMA IS OUTPUT TAD T1 / AC=INT[(LFTNUM-1)/3] CIA / AC= -INT[(LFTNUM-1)/3] TAD NUMCOM / AC= INT[(LFTFOR-1)/3]-INT[(LFTNUM-1/3] DCA NUMCOM / NUMCOM = INT[(LFTFOR-1)/3]-INT[(LFTNUM-1/3] /NUMAST: NEGATIVE OF NUMBER OF ASTERISKS TO OUTPUT BEFORE WHOLE DIGITS / NUMAST=LFTNUM-(LFTFOR+NUMCOM) AST3, TAD FRMMAT / GET FORMAT WORD SMA CLA / IF ASTERIST BIT SET JMP LFTOUT / THEN /A010 TAD LFTFOR / AC= LFTFOR TAD NUMCOM / AC= LFTFOR+NUMCOM CMA / AC= -(LFTFOR+NUMCOM) TAD LFTNUM / AC= LFTNUM-(LFTFOR+NUMCOM) DCA NUMAST / NUMAST=LFTNUM-(LFTFOR+NUMCOM) /NOW OUTPUT THE ASTERISKS AST4, ISZ NUMAST / LOOP SKP / NUMAST=NUMAST+1 JMP LFTOUT / EXIT IF DONE /A010 TAD ("*-200 / GET ASTERISK JMS STIKIT / OUTPUT TO RESULTS JMP AST4 / END_LOOP LFTOUT, /OUTPUT THE DIGITS TO THE LEFT OF THE RADIX POINT /A010 CLA TAD (ASCBUF-1 / GET ADDRESS OF SIMPLE ASCII BUFFER -1 DCA X3 / AND SET UP AUTO INDEX REGISTER TAD LFTNUM / GET NUMBER OF DIGITS TO OUTPUT SNA / IF (LFTNUM .GT. 0) JMP RGTOUT / THEN CMA / AC=-LFTNUM DCA T1 / T1= -LFTNUM JMS DIGOUT / OUTPUT ALL DIGITS TO LEFT OF RADIX RGTOUT, /HANDLE RADIX AND DIGITS TO RIGHT OF IT /A010 DCA NEXTC / CLEAR NEXTC SO NO COMMAS WILL BE OUTPUT WHEN / WE DO DIGITS TO RIGHT OF RADIX TAD DEFAUL / SNA CLA / IF DEFAULT FORMAT JMP NOTDEF / TAD RGTNUM / THEN SNA CLA / IF (RGTNUM.NE.0) JMP TRLCHR /A010 TAD (RADIX / THEN OUTPUT RADIX POINT /M008 JMS STIKIT / TAD RGTNUM / T1 = RGTNUM JMP RGTOU2 / OUTPUT DIGITS TO RIGHT OF RADIX NOTDEF, TAD RGTFOR / ELSE SNA CLA / IF (RGTFOR .NE. O) JMP TRLCHR /A010 TAD (RADIX / THEN /M008 JMS STIKIT / OUTPUT RADIX POINT AC7777 / T1 = RGTNUM-1 RGTOU1, TAD RGTFOR / RGTOU2, CMA / DCA T1 / T1 = - NUMBER OF DIGITS TO RIGHT JMS DIGOUT / OUTPUT T1 DIGITS TO RIGHT OF RADIX TRLCHR, /HANDLE TRAILING CURRENCY SYMBOL IF REQUIRED /A013 IFDEF PSTCUR < /A013 TAD FRMMAT / GET FORMAT WORD /A013 AND (CURBIT) / MASK OUT ALL BUT CURRENCY BIT /A013 SNA CLA / SKIP IF WANTED /A013 JMP TRLSGN / GO CHECK FOR TRAILING SIGN /A013 TAD (CURENC) / GET FIRST CURRENCY CHARACTER /A013 JMS STIKIT / STICK IT IN BUFFER /A013 IFDEF CS3CHR < /IF THERE ARE MORE CURRENCY SYMBOL CHARACTERS, STICK THEM/A014 TAD (CUREN2) / GET SECOND CURRENCY CHARACTER /A013 JMS STIKIT / STICK IT IN BUFFER /A013 TAD (CUREN3) / GET THIRD CURRENCY CHARACTER /A013 JMS STIKIT / STICK IT IN BUFFER /A013 > / END IFDEF CS3CHR /A014 /A013 TRLSGN, /M013 > /END IFDEF PSTCUR /A013 /HANDLE TRAILING "-" OR ")" /A010 TAD SGN / GET SIGN OF VALUE SMA CLA / IF VALUE NEGATIVE JMP I RSTOUT /A010 JMS TSTSGN / THEN TEST FORMAT OF SIGN INDICATOR JMP I RSTOUT / RETURNS HERE IF LEADING '-' (exit) TAD (")-"- / RETURNS HERE FOR PARENS (OUTPUT ')') TAD ("--200 / RETURNS HERE FOR TRAILING (OUTPUT '-') JMS STIKIT / OUTPUT '(' OR '-' JMP I RSTOUT /OUTPUT COMPLETE /A010 / DIVIDE AC BY 3 AND PUT RESULTS INTO T1 /A010 /T1=0 /AC=X /JMS DVCY3 /T1=INT(X/3) /AC=ALMOST GARBAGE DVBY3, XX /LOOP DVBY3A, TAD (-3 / SUBTRACT 3 SPA / ARE WE DONE DIVIDING? JMP I DVBY3 /EXIT IF DONE ISZ T1 / INCREMENT T1 JMP DVBY3A /END_LOOP IFDEF PRECUR < /THIS ROUTINE IS HERE IF PRE-DIGIT CS IS DEFINED OR ON THE /A013 / PREVIOUS PAGE IF POST-DIGIT CS IS DEFINED /A013 /THIS SUBROUTINE WILL TEST THE FORMAT OF THE SIGN /JMS TSTSGN / LEADING "-" RETURN / PARENS RETURN / TRAILING "-" RETURN TSTSGN, XX /TEST SIGN BIT IN FORMAT WORD TAD FRMMAT AND (0060 /MASK OFF SIGN BITS BSW /MOVE BITS OVER RAL /TO LINK AND BIT 8E-0 SNL /TEST LINK JMP TST1 /LINK=0=LEADING SIGN SMA CLA /EITHER TRAILING OR () ISZ TSTSGN / TRAILING ISZ TSTSGN / () TST1, CLA JMP I TSTSGN /RETURN > / END IFDEF PRECUR /THIS ROUTINE GETS A PACKED BCD WORD FROM THE MATH SYMBOL TABLE GETBCD, XX /A002 CDFMTH TAD I BCDPNT / GET BCD CHARACTER CDFMYF JMP I GETBCD / RETURN /THIS BUFFER HOLDS THE ASCII NUMBER TO BE OUTPUT /FROM ASCBUF TO ASCBUF+LFTNUM ARE THE DIGITS TO THE LEFT OF THE RADIX /FROM ASCBUF+LFTNUM+1 TO ASCBUF+LFTNUM+RGTNUM+1 ARE THE DIGITS TO THE / RIGHT OF THE RADIX /THERE IS NO ACTUAL DECIMAL POINT STORED SINCE LFTNUM AND RGTNUM TELLS /US ALL WE NEED TO KNOW ASCBUF,ZBLOCK MAXDIG /13 DECIMAL = MAXIMUM BCD DIGITS X=. PAGE /BCD SCAN ROUTINE. THIS ROUTINE WILL SCAN THE INPUT PACKED BCD /NUMBER AND CONVERT IT TO ASCII PUTTING IT INTO ASCBUF. THE RADIX /POINT IS NOT STORED BUT LFTNUM = THE NUMBER OF DIGITS TO THE LEFT /RADIX. THE BUFFER IS PADDED WITH ZEROES IN CASE THE USER ASKS TO /SEE MORE DIGITS TO THE RIGHT OF THE RADIX THAN WERE IN THE NUMBER DECIMAL MAXDIG=13 / MAXIMUM NUMBER OF DIGITS TO DISPLAY MAXRGT=6 / MAXIMUM NUMBER OF DIGITS TO RIGHT OF RADIX DIGCNT=17 / NUMBER OF DIGITS, INCLUDING RADIX, IN PACKED BCD OCTAL SCNBCD, XX DCA RGTNUM / INITIALIEX # OF DIGITS TO RIGHT OF RADIX NOT / INCLUDING TRAILING ZEROES DCA RGTTOT / INITIALIZE # OF DIGITS OUTPUT TO ASCII BUFFER / INCLUDING TRAILING ZEROES DCA LFTNUM / INITIALIZE # OF DIGITS TO LEFT OF RADIX DCA DIGNUM / INITIALIZE TOTOL # OF DIGITS OUTPUT TO ASCII / BUFFER DCA NONZR0 / INITIALIZE NON_ZERO_DIGIT FOUND FLAG TO FALSE TAD (-MAXDIG DCA T1 / SET UP IN COUNTER FOR BUFFER SIZE TAD (-VALSIZ DCA BCDCNT / INITILIAZE COUNT OF NUMBER OF BCD WORDS TAD (MIDBCD / DCA NXTBCD / INITIALIZE GETDIG ROUTINE TAD (ASCBUF-1 / DCA X3 / SET UP POINTER TO BUFFER IN AUTO INDEX REGISTER /INITIALIZE ASCBUF TO ALL 0'S SCN1, TAD ("0-200 / REPEAT DCA I X3 / OUTPUT "0" ISZ T1 / JMP SCN1 / UNTIL T1=0 TAD (ASCBUF-1 / DCA X3 / SET UP POINTER TO BUFFER IN AUTO INDEX REGISTER /GET RID OF LEADING ZEROS IN BCD VALUE SCN2, JMS GETDIG / LOOP; GET NEXT BCD JMP ZERO / EXIT IF END_OF_BCD (*VALUE OF NUMBER IS ZERO*) TAD (-"0+200 / SNA / EXIT IF DIGIT NOT "0" JMP SCN2 / END_LOOP /AT THIS POINT WE HAVE OUR FIRST NON_ZERO DIGIT (OR MAYBE IT'S A RADIX) TAD ("0-200-RADIX/ IF (DIG = RADIX) /M008 SZA / JMP NOTRAD / TAD DEFAUL / THEN TAD LFTFOR / IF DEFAULT OR (LFTFOR .GT. 0) SNA CLA / JMP SCNRGT / WE NEED AT LEAST ONE LEADING DIGIT UNLESS TAD ("0-200 / FORMAT SPECIFICALLY SAYS NO DIGITS TO LEFT JMS ASCOUT / OUTPUT("0") ISZ LFTNUM / LFTNUM = LFTNUM+1 JMP SCNRGT / / ELSE NOTRAD, ISZ NONZR0 / SET NON_ZERO_DIGIT FOUND FLAG TO TRUE NOTRA1, TAD (RADIX / WHILE (DIG .NE. RADIX) AND (NOT END_OF_BCD) JMS ASCOUT / OUTPUT(DIG) ISZ LFTNUM / LFTNUM = LFTNUM+1 JMS GETDIG / GET A NEW DIGIT JMP SCNEXI / /EXIT IF END_OF_BCD TAD (-RADIX / /M008 SZA JMP NOTRA1 / END_WHILE /COME HERE TO HANDLE ALL DIGITS TO RIGHT OF RADIX IN PACKED BCD SCNRGT, JMS CHKDEF / CHECK FOR DEFAULT AND OUTPUT "%" IF NEEDED SCNRG1, TAD DIGNUM / WHILE (DIGNUM<>MAXDIG) TAD (-MAXDIG / SNA CLA / JMP SCNEXI / AND (RGTTOT .LT. RGTFOR-1) AC7777 / TAD RGTFOR / CIA / TAD RGTTOT / SMA CLA / JMP SCNEXI / BEGIN JMS GETDIG / GET A NEW DIGIT JMP SCNEXI / EXIT IF END_OF_BCD DCA T2 / TAD T2 / JMS ASCOUT / OUTPUT(DIG) ISZ RGTTOT / RGTTOT = RGTTOT+1 TAD T2 / TAD (-"0+200 / (* NOW MAKE CHECK FOR TRAILING ZERO*) SNA CLA / IF (DIG .NE. "0") JMP SCNRG1 / TAD RGTTOT / THEN DCA RGTNUM / RGTNUM=RGTTOT TAD RGTFOR / IF (RGTFOR .GT. RGTNUM) CIA / TAD RGTNUM / SPA CLA / THEN ISZ NONZR0 / SET NON_ZERO_DIGIT FOUND TO TRUE JMP SCNRG1 / END_WHILE /COME HERE IF NOTHING BUT ZEROS IN BCD VALUE, (NOT SURE IF THIS MAY HAPPEN) ZERO, TAD ("0-200 /OUTPUT A LEADING "0" JMS ASCOUT ISZ LFTNUM / SET LFTNUM = 1 SCNEXI, TAD NONZR0 / IF ONLY ZEROES FOUND SNA CLA / THEN DCA SGN / SET SIGN OF VALUE TO POSATIVE JMP I SCNBCD / END_SCNBCD /THIS ROUTINE WILL PASS BACK A DIGIT FROM THE PACKED BCD BUFFER AFTER /CONVERTING IT TO ASCII. IT MAKES A REGULAR RETURN IF NO MORE BCD CHARACTERS /AND A SKIP RETURN WITH THE CHARACTER IN THE AC OTHER WISE /JMS GETDIG / END_OF_BCD RETURN / REGULAR RETURN (AC = ASCII DIGIT OR RADIX CHARACTER) NXTBCD, MIDBCD / ADDRESS OF NEXT ROUTINE TO USE: / LFTBCD TO GET LEFT DIGIT / MIDBCD TO GET MIDDLE DIGIT / RGTBCD TO GET RIGHT DIGIT GETDIG, XX JMP I NXTBCD LFTBCD, ISZ BCDCNT SKP JMP I GETDIG / NON_SKIP RETURN IF END_OF_BCD ISZ BCDPNT / POINT TO NEXT PACKED BCD WORD TAD (MIDBCD / DCA NXTBCD / SET UP ADDRESS FOR NEXT CALL TO GETDIG JMS GETBCD / GET PACKED BCD VALUE BSW RTR / PUT INTO RIGHT SIDE OF AC JMP EXTGTD / CONVERT TO ASCII THEN RETURN TO CALLER MIDBCD, TAD (RGTBCD / DCA NXTBCD / SET UP ADDRESS FOR NEXT CALL TO GETDIG JMS GETBCD / GET PACKED BCD VALUE RTR RTR / PUT INTO RIGHT SIDE OF AC JMP EXTGTD / CONVERT TO ASCII THEN RETURN TO CALLER RGTBCD, TAD (LFTBCD / DCA NXTBCD / SET UP ADDRESS FOR NEXT CALL TO GETDIG JMS GETBCD / GET PACKED BCD VALUE EXTGTD, AND (0017 / MASK OUT ALL BUT THIS DIGIT TAD (-BCDRAD SZA / IF NOT RADIX INDICATOR TAD (BCDRAD+60-RADIX /THEN CONVERT TO DIGIT /M008 TAD (RADIX / ELSE CONVERT TO RADIX /M008 ISZ GETDIG / SET UP FOR SKIP RETURN JMP I GETDIG / AND RETURN PAGE / ERROR REPORTING MECHANISM / / ****** WARNING ****** /A006 / UDTEXT AND OFTEXT ARE BOTH DEFINED IN WPF1. IF MOVED MODIFY WPF1!! /A006 / INITER, /REPORT INITIALIZE ERROR JMS REPORT /REPORT ERROR MESSAGE UDTEXT, "*-200 /*Un.def* /M006 125 /U 156 /n 056 /. 144 /d 145 /e 146 /f "*-200 0000 / OVRFLO, /REPORT OVERFLOW ERROR JMS REPORT OFTEXT, "*-200 /*Ovr.flo* /M006 117 /O 166 /v 162 /r 056 /. 146 /f 154 /l 157 /o "*-200 0000 REPORT, XX /REPORT ERROR TEXT CLA CLL NXTERR, TAD I REPORT /START THROUGH ERROR TEXT SNA /TEST FOR END JMP FINI /PASS TABLE END ... FAST EXIT JMS STIKIT /PASS TO OUTPUT BUFFER ISZ REPORT /BUMP TO NEXT IN LINE JMP NXTERR /LOOP /D002 / / / /D002 / /PASS SIMPLE ASCII OUT TO BUFFER ASCOUT, XX DCA I X3 /OUTPUT DIGIT TO ASCBUF ISZ DIGNUM /INCREMENT NUMBER OF DIGITS OUTPUT JMP I ASCOUT /THIS ROUTINE MOVE FROM ANOTHER PAGE /A008 /THIS ROUTINE OUTPUTS DIGITS TO THE RESULT BUFFER /T1=-NUMBER OF DIGITS TO OUTPUT /X3= AUTO INDEX REGISTER TO USE POINTING TO DIGITS /NEXTC= - NUMBER OF DIGITS TO OUTPUT UNTIL NEXT COMMA / IF NEXTC = 0 THEN NO COMMAS WILL BE OUTPUT DIGOUT, XX DIGOU1, ISZ T1 / LOOP; INCREMENT COUNTER SKP JMP I DIGOUT / EXIT IF DONE TAD I X3 / GET NEXT DIGIT JMS STIKIT / OUTPUT TO RESULT BUFFER ISZ NEXTC / IF A COMMA IS DUE JMP DIGOU1 / AC0001 / AND THEIR ARE MORE DIGITS TO OUTPUT TAD T1 SNA CLA JMP DIGOU1 / / TAD (",-200 / THEN GET COMMA /d012 TAD SEPSYM / THEN GET SEPERATOR /A012 JMS STIKIT / AND OUTPUT TAD (-3 / NOW RESET NEXTC FOR NEXT COMMA DCA NEXTC JMP DIGOU1 / END_LOOP /D002 SEPSYM, / Seperator symbol /a012 IFDEF ENGLSH< /a012 ",-200 > /a012 IFDEF DUTCH< /a015 ".-200 > /a015 IFDEF ITALIAN< /a012 ".-200 > /a012 IFDEF SPANISH< /a013 ".-200 > /a013 IFDEF V30NOR< /a014 ".-200 > /a014 IFDEF V30NOR< /a014 ".-200 > /a014 /**************************************************************************** / / This routine moved here from LEXASC to create room for changes /a011 / to allow technical and multinational characters in maths /a011 / symbolic names. /a011 / /**************************************************************************** /LEXic_ReaD_CHARacter: /begin / set Special_CHaRacter_Skip_Flag / repeat / | read character / | set LeXical_CHaRacter = character in AC / | if [LeXical_CHaRacter = 0 (buffer terminater for error reporting] / | escape until / | if [LeXical_CHaRacter&177(8) = special_character (ASCII < 41)] / | posit / | | if [LeXical_CHaRacter&177(8) = "new_line"] / | | | if [LeXical_CHaRacter = "special_new_line character"] / | | | quit posit / | | | / | | orif [LeXical_CHaRacter&177(8) = "start_dead"] /a011 / | | | set DEAD_KEY_sequence_flag /a011 / | | | quit posit /a011 / | | | /a011 / | | orif [LeXical_CHaRacter&177(8) = "end_dead"] /a011 / | | | reset DEAD_KEY_sequence_flag /a011 / | | | quit posit /a011 / | | | / | | orif [Special_CHaRacter_Skip_Flag = don't skip spaces or tabs] / | | | if [LeXical_CHaRacter&177(8) = "space"] / | | | | if [LeXical_CHaRacter = "special_space"] / | | | | quit posit / | | | else / | | | if [LeXical_CHaRacter&177(8) <> "tab"] / | | | quit posit / | | else / | | set LeXical_CHaRacter = 0 / | end_posit / | / until [LeXical_CHaRacter neq 0 (valid character)] / / Set AC = LeXical_CHaRacter&177(8) (strip mode bits) / / return / /!!!!!!!!!!!! special text format codes (in text buffer) !!!!!!!!!!!!!!!!!!!!! /!! ECMDFL = 7 /"line_modified_flag" /!! ECRMFL = 207 /"ruler_modified_flag" /!! ECSTOV = 10 /"start_dead_key_sequence" /!! ECTAB = 11 /"tab" /!! ECNWLN = 12 /"new_line" /!! ECWWLN =2012 /"wrapped_line" /!! ECHYLN =2412 /"wrapped_line_with_hyphen" /!! ECSLPT =3412 /"select_point" /!! ECPGRF =1012 /"end_paragraph" /!! ECENLN =1412 /"centered_line" /!! ECNWPG = 14 /"new_page" /!! ECPMRK =2014 /"page_marker" /!! ECNDOV = 15 /"end_dead_key_sequence" /!! ECSPC = 40 /"space" /!! ECJSPC =2040 /"justifing_space" /!! ECTMRK =3040 /"position_marker" /!! ECCMRK =3440 /"rejustification_positon_marker" /!! ECPHYP =2055 /"printing_break_hyphen" /!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! / LXRDCH, XX DCA SCHRSF / set Special_CHaRacter_Skip_Flag / if SCHRSF = 1 skip all spec. chars. except / If SCHRSF = 0 skip all spec. chars. except , / space, and tab. RDF / Get the calling field number, for /a011 TAD CIDF0 / cross field call and make CIDF instr. /a011 DCA RETID / Save it for return /a011 CDFMYF / Change data field to here /a011 / LEXRD1, CIFMTH / The RDLNBF routine is in math field /a011 JMS LXRDLNB / ReaD_LiNe_BuFfer character /m011 DCA LXCHR / save character /m011 TAD LXCHR SNA / skip if: character <> 0 JMP LEXRD7 / buf. term. (0) for error reporting detected AND P177 / ignore attribute bits for now TAD (-41 / see if special character SMA JMP LEXRD6 / not special char. - so hold onto it in FRMCHR TAD (-ECNWLN+41) / is character = "new_line"? SZA CLA / skip if: so JMP LEXRD2 / nope. go check for other special characters JMP LEXRD3 / check for = "wrapped_line", "wrapped_line_with_- / hyphen", "select_point", "end_paragraph", or / "centered_line"? (whew!!) LEXRD2, TAD LXCHR / Get the character read /a011 TAD (-ECSTOV) / Check for start of dead key sequence /a011 SNA / Is it the start of a dead key? /a011 JMP STDEAD / Yes, set flag /a011 TAD (ECSTOV-ECNDOV) / No, check for end of dead sequence /a011 SNA CLA / Is it the end? /a011 JMP ENDEAD / Yes, reset the flag /a011 TAD SCHRSF / ignore spaces and tabs? SZA CLA / skip if: don't ignore JMP LEXRD5 / ignore TAD LXCHR /m011 AND P177 TAD (-ECSPC) / is character a "space"? SZA / skip if: so JMP LEXRD4 / no - go check for "tab"? LEXRD3, TAD LXCHR / is character a "wrapped_line", "wrapped_line_with_- / hyphen", "select_point", "end_paragraph", "center- / ed_line", "justify_space", "position_marker", or / "rejustification_positon_marker"? /m011 AND (3000) SZA CLA / skip if: not JMP LEXRD5 / it's one of the above so ignore / this character! JMP LEXRD6 / hold onto character in FRMCHR LEXRD4, TAD (-ECTAB+ECSPC) / is character a "tab"? SZA CLA / skip if: so LEXRD5, DCA LXCHR / set FRMCHR = 0 /m011 LEXRD6, CLA TAD LXCHR / do we have a valid char.? /m011 SNA / skip if: so JMP LEXRD1 / no - well go get one!!! / LEXRD7, AND P177 / get rid of mode bits /D011 JMS DCAFRM / restore character less mode bits. RETID, XX / Area for returning CIDF instruction /a011 / JMP I LXRDCH / return / STDEAD, CDFMTH / Tickle the dead key flag in the math /a011 ISZ I DEADPTR / field to prevent counting dead keys as/a011 BACKL6, CDFMYF / more than one character /a011 JMP LEXRD6 / Exit with start dead character /a011 ENDEAD, CDFMTH / Reset the dead key flag in the math /a011 DCA I DEADPTR / field at end of dead key sequence /a011 JMP BACKL6 / Reset data field and exit with End dead/a011 / SCHRSF, 0 / Special_CHaRacter_Skip_Flag LXCHR, 0 / LEXic_CHaRacter /a011 DEADPTR,DEADKEY / DEAD_key_sequence_flag_PoinTeR /a011 / / PAGE