PRINTUSING MODULE INCLUDE SMACS INCLUDE XMACS INCLUDE DBMACS UNLISTG *DEFINE CURRENCY CHARACTER &CURRENCYCH EQU C'#' CDATA FILEDATA RESTOFFORMAT LWORD *DR TO REMAINDER OF FORMAT FORMAT LWORD *DR TO WHOLE FORMAT DATA AREAPROPS AREATYPE=DATA,PUBLIC=1 SPECCHARS CHS(8) C'*',C'+',C'-',C'.',C'^', -C'<',C'>',&CURRENCYCH &PUBUFLEN AWORD 160 *MAX LENGTH OF FORMAT STRING SUBTITLE 2 *CALLED TO INITIALISE THE PRINT USING ROUTINES. THE PARAMETER IS *A DESCRIPTOR TO THE FORMAT STRING CHAPTER AREAPROPS AREATYPE=CODE,PUBLIC=1 PUSTART PROC PARAMS FORMATDR LWORD LOCAL CODE LSD FORMATDR OR &BCI/0 *SO I CAN MODD TO THE END ST FORMAT *DR TO COMPLETE FORMAT ST RESTOFFORMAT LSS 0 *ERROR RESPONSE EXIT SUBTITLE 3 *OUTPUT A VALUE ACCORDING TO THE SPECIFIED FORMAT STRING. *RESTOFFORMAT IS A DESCRIPTOR TO THE CURRENT POSITION IN THE FORMAT. *ON EXIT ACC CONTAINS A POSITIVE VALUE IF AN ERROR IS DETECTED PUVALUE PROC PARAMS VALUE LREAL LOCAL LOCALRESTF LWORD *LOCAL COPY OF RESTOFFROMAT BUFFERDR LWORD *DR TO WHILE OF TEMP BUFFER TEMPDR LWORD BOFFSET WORD *NEXT FREE POSN IN BUFFER RDIGITS INT *TEMP USED IN ROUND SUBROUTINE VSIGN INT *SIGN OF VALUE -1,0 OR 1 IPOINT INT *POSITION OF . IN BUFFER (OR -VE) ICURRENCY INT *POSITION OF # IN BUFFER (OR -VE) ISIGN INT *POSITION OF + OR - IN BUFFER IUPARROW INT *POSITION OF FIRST ^ IN BUFFER (OR -VE) NFPA INT *NUMBER OF FORMAT PLACES AFTER . NFPB INT *NUMBER OF FORMAT PLACES BEFOTE . NFP INT *NFPB+NFPA EXP INT *EXPONT PART OF NUMBER NFFP INT *NUMBER OF FIXED FORMAT POSITIONS FOR # AND +OR - SIGN INT *C'+' OR C'-' OR C' ' CHAR INT *CURRENT FORMAT CHAR BEING PROCESSAD CODE *INITIALISE VARIOUS LOCALS STSF.B *CREATE ON STACK VECTOR ASF (&PUBUFLEN/4) *FOR FORMATTED ITEM LDA.B LDTB (&BV+&BCI+&PUBUFLEN) STD BUFFERDR LSS -1 ST IPOINT ST ICURRENCY ST IUPARROW LSS 0 ST BOFFSET ST NFPA ST NFPB *IF AT END OF FORMAT WRAP AROUND LD RESTOFFORMAT JNZDL START #HLCALL .OUTPUTNL JP ERREXIT *POSSIBLY NO TO MORE LD FORMAT START STD LOCALRESTF SUBTITLE 2 * ANALYSE A MOULD OF THE FORM :- * {#} +OR- { **.. } { .**.. } {^^^^^} JLK ENTRY2GETC *PRIME INPUT ROUTINES JLK DOCURRENCY JLK DOSIGN JLK DOSTARS JLK DOFRACTION JLK DOEXPONENT *CHECK POSSIBLE START OF NEXT MOULD LSS CHAR JZ FITVALUE *END OF FORMAT FLAG ICP C'*' JE ERROR ICP C'^' JE ERROR ICP C'.' JE ERROR *BACKSPACE OVER LAST CHAR WHICH IS THE START OF NEXT FIELD LSD LOCALRESTF IAD 0/-1 ST LOCALRESTF J FITVALUE *FIT VALUE INTO ANALYSED FORMAT STRING SUBTITLE 1 *INPUT # IF THERE IS ONE DOCURRENCY LSS CHAR ICP &CURRENCYCH JNE DCX LB BOFFSET STB ICURRENCY JLK GETCHAR DCX J.T SUBTITLE 1 *INPUT OBLIGITARY + OR - DOSIGN LSS CHAR ICP C'+' JE DS1 ICP C'-' JNE ERROR DS1 LB BOFFSET STB ISIGN JLK GETCHAR J.T SUBTITLE 1 * INPUT SEQUENCE (POSSIBLE EMPTY) OF *S DOSTARS LSS CHAR ICP C'*' JNE DISX LSS NFPB IAD 1 ST NFPB JLK GETCHAR J DOSTARS DISX J.T SUBTITLE 1 *INPUT POSSIBLE FRACTION FORM DOFRACTION LSS CHAR ICP C'.' JNE DFX LB BOFFSET STB IPOINT JLK GETCHAR LSS CHAR ICP C'*' JNE ERROR JLK DOFSTARS DFX J.T SUBTITLE 1 *INPUT *S AFTER THE . DOFSTARS LSS CHAR ICP C'*' JNE DFSX LSS NFPA IAD 1 ST NFPA JLK GETCHAR J DOFSTARS DFSX J.T SUBTITLE 1 *CHECK FOR POSSIBLE ^^^^^ DOEXPONENT LSS CHAR ICP C'^' JNE DEX LB BOFFSET STB IUPARROW JLK GETCHAR JLK DOUPARROW JLK DOUPARROW JLK DOUPARROW JLK DOUPARROW DEX J.T SUBTITLE 1 *INPUT 1 ^ DOUPARROW LSS CHAR ICP C'^' JNE ERROR JLK GETCHAR J.T SUBTITLE 1 *IPPUT TO NEXT SPECIAL CHAR SAVING CHARS IN BUFFER GETCHAR * SAVE PREVIOUS CHAR LSS CHAR GETCHAR2 LB BOFFSET ST.MI BUFFERDR *SAVE CURRENT CHAR ADB 1 STB BOFFSET ENTRY2GETC *INITIALISATION ENTRY LD LOCALRESTF *GET NEXT CHAR JZDL ENDGETCHAR LB.D CYD IAD -1/1 *MODD 1 ST LOCALRESTF * SEE IF SPECIAL CHAR I.E. +-*.#^<> LD D'SPECCHARS SWNE JNE GETCHARX *IS SPECIAL LSS.B *NOT SPECIAL J GETCHAR2 *GO ROUND AGAIN ENDGETCHAR LB 0 GETCHARX STB CHAR J.T SUBTITLE 1 *FIT THE VALUE INTO THE FORMAT COPIED INTO THE BUFFER FITVALUE TRACE LOCALRESTF,BUFFERDR,BOFFSET,TEMPDR,VSIGN,IPOINT, -ICURRENCY,ISIGN,IUPARROW,NFPA,NFPB -NFP,EXP,NFFP,SIGN,CHAR LSS NFPA *NO. OF *S AFTER . IAD NFPB *NO OF *S BEFORE . ST NFP SUBTITLE 1 *CHECK VALUE FOR NORMALISATION AND SIGN *SET VSIGN TO -1,0,1 AND SET VALUE TO ABS(VALUE) LB 1 LSD VALUE JZR ZEROVAL *SEE IF NORMALISED AND X'F00000'/0 JZ NOTNORMAL LSD VALUE JPR POSITVAL RRSB 0 LB 0 ZEROVAL SBB 1 *TO GIVE -1 OR 0 POSITVAL STB VSIGN *CALL FPNORMALISE TO CONVERT VALUE TO RANGE =E15 STLN.T ASF 4 ST.T RALN 7 CALL .FPNORMALISE RESTOREXNB STB EXP ST VALUE *SEE IF EXPONENT MOULD LSS IUPARROW JN NOEXPONENT TITLE 1 *MOULD IS OF EXPONENT TYPE *SET SIGN FIALD AS SPECIFIED LB ISIGN LSS VSIGN JNN EXPF1 *VALUE IS 0 OR +VE LSS C'-' ST.MI BUFFERDR *SET SIGN TI - J EXPF2 EXPF1 LSS.MI BUFFERDR *SEE IF + OR SPACE REQD ICP C'-' JNE EXPF2 *LEAVE + AS IT IS LSS C' ' ST.MD *SET - TO SPACE EXPF2 LB NFP *ROUND VALUE ACCORDING TO NO. OF *S JZB ERROR JLK ROUND *RETURNS 15 DIGIT DECIMAL VALUE LEFT *JUSTIFIED IN ACC LD BUFFERDR EXPF4 SWNE X'0',C'*' *FIND NEXT DIGIT POS JE EXPF3 *ALL DIGITS DONE SUPK.N 1 *NEXT DIGIT TO BUFFER J EXPF4 EXPF3 LSS VSIGN *CORRECT EXP IF VAL<>0 JZ EXPF5 LSS EXP *EXP:=EXP-NFPB ISB NFPB ST EXP EXPF5 LD BUFFERDR *CREATE EXPONENT FIELD MODD IUPARROW MVL.N 1,X'0',C' ' MVL.N 1,X'0',C'E' LB C'+' *GET EXPONENT SIGN LSS EXP JNN EXPF6 LB C'-' IRSB 0 *EXP:=ABS(EXP) EXPF6 MVL.N 1 *PUT SIGN OF EXP LB C' ' IMDV 10 *GET 2 DIGITS OF EXP JZ EXPF7 *ONE DIGIT EXPONENT ST.B ADB C'0' EXPF7 MVL.N 1 *FIRST DIGIT OR SPACE LSS.T IAD C'0' *LS DIGIT OF EXPONENT ST.D J ALLDONE *EXPONENT MOULD DONE TITLE 1 *OUPTUT IN FRACTION/INTEGER FORM IF THERES ROOM NOEXPONENT LB NFPA *ROUND THE VALUE TO EXP+NFPA DIGITS ADB EXP JLK ROUND *DECIMAL NO. RETURNED IN ACCC ST VALUE *IF EXP <=-NFPA THEN VSIGN:=0; LSS EXP IAD NFPA JP NX52 LSS 0 ST VSIGN NX52 *CALCULAT NUMBER OF POSITIONS REQD FOR # AND SIGN LB 1 LSS ICURRENCY JN NX1 LB 2 NX1 STB NFFP *NUMBER OF FIXED FORMAT POSITIONS *REMEMBER SIGN EQD AS +,- OR SPACE SET SIGN POSITION TO * * IF NO EXPLICIT SIGN REQD LB ISIGN LSS VSIGN JNN NX2 LSS C' ' *NO. IS -VE SIGN MUST BE - ST.MI BUFFERDR LSS C'-' J NX3 NX2 LSS.MI BUFFERDR *SEE IF + REQD ICP C'+' JNE NX4 LSS C' ' *+ SIGN IS REQD ST.MD LSS C'+' J NX3 NX4 LSS NFPB *NO SIGN REQD, USE SIGN POSN AS IAD 1 *POSSIBLE DIGIT POSN ST NFPB LSS NFP IAD 1 ST NFP LSS NFFP ISB 1 ST NFFP LSS C'*' ST.MD LSS C' ' NX3 ST SIGN *+,- OR SPACE LB ICURRENCY *SET # TO SPACE JNB NX5 *NO @ IN FORMAT LSS C' ' ST.MI BUFFERDR NX5 *SEE IF ENOUGH PLACES TO PRINT THE NUMBER LSS EXP ICP NFPB JG NX6 *SET SIGN POSN TO * AND FINISH LSS NFP *SEE IF AT LEAST ONE DIGIT POSN JNZ NX7 NX6 LB ISIGN *NUMBER TOO BIG FOR THIS FORMAT LSS C'*' ST.MI BUFFERDR LB ICURRENCY JNB ALLDONE ST.MD *SET # POSN TO * J ALLDONE NX7 LB NFPB *SET UNNEEDED *S TO SPACES LSS EXP JN NX8 SBB EXP NX8 LD BUFFERDR LSS C' ' JZB NX9 *B CONTAINS NO OF SUPERFLUOUS *S NX10 SWNE X'0',C'*' ST.D *REPLACE BY SPCCE DEBJ NX10 NX9 *IF THE NUMBER <1 AND THERES A . IN THE FORMAT AND *THERES ROOM PUT A 0 BEFORE THE . LB EXP JPB NX11 *EXP -VE OR ZERO I.E. VALUE <1 LSS IPOINT JN NX12 *NO POINT IN FORMAT AND VALUE<1 *SEE IF THERES MORE THAN NFFP SPACES BEFORE THE . LD BUFFERDR LDB IPOINT LB 0 NX14 SWNE X'0',C' ' JE NX13 MODD 1 ADB 1 CPB NFFP JLE NX14 INCA 1 LD BUFFERDR *INSERT 0 IN SPACE BEFORE . MODD IPOINT NX15 INCA -1 LSS.D ICP C' ' JNE NX15 NX12 LSS C'0' ST.D J NX17 NX11 LSD VALUE *PUT DIGITS BEFORE ., NO OF DIGITS IN B SWNE X'0',C'*' STD.T *SAVE DR TO FIRST DIGIT NX16 SUPK.N 1 SWNE X'0',C'*' DEBJ NX16 *NEXT DIGIT ST VALUE LD.T *RESTORE DR TO FIRST DIGIT J NX17 NX13 LD BUFFERDR *NOT ROOM FOR 0 BEFORE . MODD IPOINT *ADD SIGN IN SPACE BEFORE DIGITS NX17 LSS SIGN ICP C' ' JE NX18 *NO SPACE REQD NX19 INCA -1 LB.D CPB C' ' JNE NX19 ST.D *SET SIGN *PLACE CURRENCY SIGN IF REQD NX18 LSS ICURRENCY JN NX20 *NO CURRENCY SIGN NX21 INCA -1 LB.D CPB C' ' JNE NX21 LSS &CURRENCYCH ST.D NX20 *PUT DIGITS AFTER . LD BUFFERDR LB EXP NX23 JNNB NX25 *END LEADING ZEROS SWNE X'0',C'*' JE NX22 MVL.N 1,X'0',C'0' ADB 1 J NX23 NX25 LSD VALUE *NOW OUTPUT REAL DIGITS NX24 SWNE X'0',C'*' JE NX22 *NO MORE DIGIT POSITIONS SUPK.N 1 J NX24 NX22 *ITS ALL BEEN DONE, JUST SET THE PARAMETERS FOR RETURN ALLDONE LSD LOCALRESTF ST RESTOFFORMAT *OUTPUT THE FORMATTED ITEM LD BUFFERDR LDTB &BV LDB BOFFSET STLN.T ASF 4 STD.T RALN 7 CALL .OUTSTR EXIT ERROR LSS 20 *ERROR RESPONSE CODE TRACE C'*****ERROR IN FORMAT' TRACE LOCALRESTF,BUFFERDR,BOFFSET,TEMPDR,VSIGN,IPOINT, -ICURRENCY,ISIGN,IUPARROW,NFPA,NFPB -NFP,EXP,NFFP,SIGN,CHAR ERREXIT EXIT TITLE 1 *UNNORMALISED NUMBER, OUPUT ?S NOTNORMAL LB ISIGN LSS C'?' ST.MI BUFFERDR NN2 SWNE X'0',C'*' JE NN1 *ALL DIGITS DONE MVL.N 1,X'0',C'?' J NN2 NN1 LB IUPARROW JNB ALLDONE LD BUFFERDR MODD IUPARROW MVL.N 5,X'0',C'?' J ALLDONE SUBTITLE 1 *ROUND VALUE TO NUMBER OF PLACES IN B & CONVERT TO DECIMAL ROUND *IF RDIGITS<0 THEN RETURN 0 *IF RDITITS >15 THEN RDIGITS:=15 JNB ROUNDZERO *RETURN DECIMAL ZERO CPB 15 JL ROUND1 *RDIGITS TOO BIG LB 15 ROUND1 STB RDIGITS LSD VALUE FIX.B *DOUBLE INTEGER MYB 4 ISH.B *PROPERLY ALIGNED CDEC *QUAD DECIMAL ST.T *GET ROUNDING NUMBER REQD LSQ X'5C' *5 IN DECIMAL LB 15 SBB RDIGITS DSH.B ROUND2 DAD.T *NOW TEST STILL < E16 DCP 0/X'10'/0/X'C' *E16 IN QUAD DECIMAL JL ROUNDOK LB EXP ADB 1 STB EXP DSH -1 ROUNDOK DSH -1 *15 DIGITS SETACS 2 *DL DECIMAL J.T ROUNDZERO LSD X'C' *DECIMAL ZERO J.T SETSUBS TITLE 4 *OUTPUT A STRING IN THE SPECIFIED FORMAT * <***** IMPLIES LEFT JUSTIFICATION * >****** IMPLIES RIGHT JUSTIFICATION *ON EXIT ACC IS POSITIVE IF AN ERROR IS DETECTED PUSTRING PROC PARAMS STRING LWORD *BYTE DESC TO STRING LOCAL BUFFERDR LWORD LOCALRESTF LWORD BOFFSET WORD *INDEX TO BUFFER AREA CODE *GET DR TO BUFFER IN WHICH RESULT IS PUT STSF.B *CREATE ON STACK VECTOR ASF (&PUBUFLEN/4) *FOR FORMATTED ITEM LDA.B LDTB (&BV+&PUBUFLEN) STD BUFFERDR *IF AT END OF FORMAT, WRAP AROUND LD RESTOFFORMAT JNZDL SAVEINLOCAL #HLCALL .OUTPUTNL JP ERREXIT *POSSIBLY NO TO MORE LD FORMAT SAVEINLOCAL STD LOCALRESTF LB 0 STB BOFFSET *POINTER INTO TEMP BUFFER JLK GETFCHAR *GET NEXT SPECIAL CHAR, COPYING OTHER ICP C'>' *CHARS INTO THE BUFFER JE RJUST ICP C'<' JNE ERROR *LEFT JUSTIFICATION JUST COPY THE STRING ACROSS LJLOOP JLK PUTSCHAR *PUT NEXT STRING CHAR INTO BUFFER JLK GETSTAR *COPY TO NEXT STAR OR SPECIAL CHAR JZ ALLDONE *END OF FIELD J LJLOOP SUBTITLE 1 *RIGHT JUSTIFICATION, COUNT NUBBER OF STARS IN MOULD RJUST LD LOCALRESTF LSS 1 *COUNT OF STARS, START AT 1 FOR > JZDL RJ1 *END FORMAT RJ3 LB.D *LOOK AT NEXT FORMAT CHAR CPB C'*' JNE RJ2 *NOT A * IAD 1 *WAS A *, COUNT IT RJ6 MODD 1 JNZDL RJ3 RJ1 ST.B *AT END OF FORMAT, NO. OF *'S IN ACC LSS STRING *COMPARE WITH STRING LENGTH AND X'FFFFFF' IRSB.B JN TOOLONG *STRING LONGER THAN FORMAT *PUT LEADING SPACES INTO BUFFER ST.B JZB LJLOOP *TREAT AS LEFT JUSTIFIED RJ4 STB.T LSS C' ' JLK PUTCHAR JLK GETSTAR *NEXT FORMAT STAR JZ ALLDONE *MIGHT HAVE NULL STRING LB.T DEBJ RJ4 J LJLOOP *TREAT AS LEFT JUSTIFIED RJ2 STD.T LD D'SPECCHARS *SEE IF OTHER SPECIAL CHAR SWNE JNE RJ5 *YES - END OF MOULD LD.T J RJ6 RJ5 LD.T J RJ1 *STRING LONGER THAN FORMAT FIELD, LOOSE START OF STRING TOOLONG IRSB 0 *GET DIFFERENCE TO B ST.B LD STRING MODD.B STD STRING J LJLOOP *ALL FINISHED, SET PARAMETERS FOR RETURN ALLDONE LSD LOCALRESTF ST RESTOFFORMAT *NOW OUTPUT THE FORMATTED ITEM LD BUFFERDR LDB BOFFSET STLN.T ASF 4 STD.T RALN 7 CALL .OUTSTR EXIT ERROR LSS 20 *ERROR RESPONSE CODE ERREXIT EXIT SUBTITLE 2 *GET NEXT SPECIAL CHAR FROM FORMAT, CHARS BEFORS THE SPECIAL ARE *COPIED TO THE BUFFER GETFCHAR LD LOCALRESTF JZDL END LB.D MODD 1 STD LOCALRESTF LSS.B LD D'SPECCHARS *SEE IF SPECIAL CHAR SWNE JE NOTSPECIAL J.T *FOUND SPECIAL CHAR NOTSPECIAL JLK PUTCHAR J GETFCHAR END LSS 0 J.T SUBTITLE 1 *PUT NEXT STRING CHAR INTO BUFFER PUTSCHAR LD STRING LSS C' ' JZDL PS1 CYD IAD -1/1 *MODD 1 ST STRING LSS.D PS1 JLK PUTCHAR J.T SUBTITLE 1 *GET NEXT STAR (OR SPECIAL CHAR) GETSTAR JLK GETFCHAR JZ ENDFORMAT ICP C'*' JE GOTSTAR *BACKSPACE OVER SPECIAL CHAR *FIRST TEST IF VALID START MOULD SPECIAL ICP C'.' JE ERROR ICP C'^' JE ERROR LSD LOCALRESTF IAD 0/-1 ST LOCALRESTF ENDFORMAT LSS 0 *END FIELD FLAG GOTSTAR J.T SUBTITLE 1 *PUT CHAR INTO BUFFER PUTCHAR LB BOFFSET ST.MI BUFFERDR ADB 1 STB BOFFSET J.T ****