SEARCH MTHPRM,FORPRM TV FORCNV CONVERSION ROUTINES ,7(4201) ;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1981, 1987 ;ALL RIGHTS RESERVED. ; ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED ;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE ;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER ;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY ;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY ;TRANSFERRED. ;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE ;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT ;CORPORATION. ;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS ;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. SUBTTL REVISION HISTORY COMMENT \ ***** Begin Revision History ***** 256 ----- CORRECT %LSTDR TO CHANGE F%ELT TO F%EXT 345 (Q2322) OUTPUT 2 WORDS OF DBLE PREC VAR EVEN IF F FORMAT REQUIRED 347 ----- RESTRICT DELIMITER FOR LIST-DIRECTED INPUT TO BLANK, COMMA AND LINE TERMINATOR 350 (13704) LIST-DIRECTED INPUT DOES NOT TAKE END= RETURN 354 ----- FIX FREE FORMAT ON INPUT 357 ----- REDEFINE LABEL ERROR FOR MACRO V50 366 ----- FIX LIST DIRECTED I/O FOR ARRAYS 367 (13951) FIXED INTEGER FORMAT LOOSES BLANKS AT END OF RECORD 372 ----- FIX NAMELIST 373 (13917) FIX SCALING FACTOR 374 ----- END OF NAMELIST LIST FOR F10-V2 376 ----- CORRECT FIXED "A" FORMAT AFTER FREE FORMAT 377 ----- FIX F FORMAT 400 ----- FIX TO EDIT 372 426 15142 HAVE NAMELIST ACCEPT ANY 6 CHARS NAMELIST NAME 430 15596 FIX SO SCALING ON OUTPUT AFTER NAMELIST INPUT WORKS 433 15880 FIX INPUT OF OCTAL NUMBERS TO CORRECTLY HANDLE MINUS SIGN 441 16108 FIX %FLOUT SO SINGLE PREC. NOS. LIKE -1.999999 DON'T LOSE PRECISION 445 16517 FIX NAMELIST INPUT SO FLOATING POINT TO INTEGER CONV. WORKS FOR ALL CASES EVEN #'S LIKE 1.0 ***** Begin Version 4C ***** 461 16741 FIX NAMELIST TO ACCEPT ANY 6 CHAR VARIABLE NAME 462 16796 FIX %FLIRT SO CALL TO ILL CAUSES ILLEGAL CHARS IN DATA TO BE SET TO ZERO AND NOT SKIP VALID FOLLOWING CHARS 465 17142 FIX %NMLST TO INPUT STRINGS INTO DOUBLE PRECISION AND COMPLEX VARIABLES CORRECTLY. 476 17725 FIX G FORMAT WHEN FIELD TOO SMALL UNLESS 4X REMOVED. 517 18268 FIX F2.0 TO NEVER PRINT JUST A DOT. 533 19239 FIX %LSTDR TO CORRECTLY INPUT STRINGS INTO DOUBLE PRECISION NUMBERS. 534 19239 FIX %NMLST FOR INPUT OF STRINGS INTO ARRAYS 541 19793 FIX %NMLST FOR LIST-DIRECTED INPUT OF QUOTED STRINGS INTO ARRAYS WILL CLEAR F%QOT 544 12882 MAKE P SCALING WORK WITH F FORMAT FOR NUMBERS WHICH ARE IDENTICALLY ZERO 563 (V5) MAKE F FORMAT USE BOTH WORDS FOR DOUBLE PRECISION (%FLIRT AND %FLOUT) 566 Q00569 PRINT ZERO EXPONENT FOR IDENTICAL ZERO, D OR E FORMAT (%FLOUT) 574 Q00654 LIST DIRECTED INPUT OF COMPLEX NUMBERS SHOULD REQUIRE PARENTHESIS AROUND THE ARGUMENT, AND IF THERE IS A REPEAT COUNT IT SHOULD BE DELIMITED BY AN ASTERISK. 575 18964 LIST-DIRECTED I/O DOES NOT PROPERLY HANDLE S-LISTS WITH INCREMENTS NOT EQUAL TO ONE. 576 18964 LIST DIRECTED INPUT DOES NOT PROPERLY HANDLE S-LISTS WITH INCREMENTS OTHER THAN ONE. BEGIN VERSION 5A, 7-NOV-76 622 QA873 NAMELIST PARTIAL ARRAYS AT END OF LIST ***** Begin Version 5A ***** 652 22508 EXPONENT FIELDS SHOULD ACCEPT LOWER CASE D AND E 653 22543 ACCEPT LOWER CASE T AND F FOR TRUE AND FALSE 654 ----- FIX FLIRT TO HANDLE ALL INTEGERS CORRECTLY AND FIX NAMELIST TO STORE DATA TYPE IN LOW CORE 660 ----- FIX %FLOUT TO USE 8 NOT 9 AS MAX NUMBER OF MANTISSA DIGITS TO PRINT ON SINGLE PRECISION SO 5.55 IN F20.17 WON'T PRINT AS 5.55000001... NULLIFIED IN VERSION 6 - THE SINGLE PRECISION REPRESENTATION OF 5.55 IS 5.55000001. IF THE USER WANTS MORE DIGITS THAN THE "ACCURACY" OF THE MACHINE, WE WILL PRINT WHAT IS THERE, SO AS TO PRINT ENOUGH PRECISION TO HAVE ABSOLUTE DIFFERENTIATION BETWEEN NUMBERS (I.E., SO THAT OUTPUT FOLLOWED BY INPUT WILL ALWAYS YIELD THE SAME INTERNAL REPRESENTATION). 673 22607 IMPLEMENT VBL WIDTH DOUBLE PRECISION OCTAL I/O. ***** Begin Version 5B ***** 735 24788 FIX EDIT 673 FOR KA SO THAT NEXT WORD IS NOT OVERWRITTEN WHEN DOING SINGLE PRECISION OCTAL INPUT 740 24891 FIX LIST-DIRECTED/NAMELIST OUTPUT TO SET G FORMAT FLAG BEFORE CALLING %REAL ON EACH PART OF COMPLEX VBL 756 25638 USE DEFAULT F FORMAT TO COUNT THE NO. OF ZEROS AFTER DECIMAL POINT WHEN THE NUMBER IS TOO SMALL TO PRINT. 761 11923 FIX EDIT 654 TO HANDLE INPUT INTEGERS CORRECTLY IN %FLIRT. 764 26523 IN %NMLST, CHECK FOR NULL FIELDS WITH LIST DIRECTED INPUT OF LOGICAL VARIABLE. 770 26836 FIX %NMLST TO HANDLE THE NAMELIST COMPLEX ARRAYS CORRECTLY BEGIN VERSION 6 REWORK ALL CONVERSION ROUTINES SO THEY HAVE SEPARATE INPUT AND OUTPUT ENTRY POINTS WITH COMMON SETUP ROUTINES. SEPARATED R-FORMAT CODE FROM A-FORMAT CODE, BUT USED COMMON SETUP ROUTINES. REDUCED NUMBER OF ACCUMULATORS USED BY FLIRT AND FLOUT, AND REWORKED ALL CONVERSION ROUTINES TO USE VERSION 6 ACCUMULATOR CONVENTIONS. INSTALLED EXTENDED EXPONENT HANDLING IN FLIRT, FLOUT, AND NAMELIST/LIST-DIRECTED I/O. INSTALLED SPARSE POWER OF TEN IN POWTAB FOR USE WITH EXTENDED EXPONENT. INCREASED NUMBER OF ENTRY POINTS IN FLOUT, AND THEREBY MADE G-FORMAT FLAG, E-FORMAT FLAG, AND D-FORMAT FLAG LOCAL TO FLOUT (ALTHOUGH THEY ARE STILL DEFINED IN FORPRM). MADE ALL NUMBER-HANDLING IN FLIRT/FLOUT DOUBLE-PRECISION, THUS ELIMINATING EXTRA SINGLE-PRECISION CODE, INCREASING ACCURACY OF SINGLE PRECISION NUMBERS, AND INCREASING TIME SPENT BY 1% OR SO. COMPLETELY REWROTE ROUNDING ALGORITHM, USING 9'S DIGIT COUNTER INSTEAD OF ADDING (INACCURATE) AMOUNTS FROM A ROUNDING TABLE. REMOVED OPTIONAL LEADING ZERO FROM FLOUT, THEREBY REMOVING A GREAT DEAL OF EXCESS CODE. IMPLEMENTED VARIABLE-SIZE EXPONENT WIDTH, INCLUDING LEAVING OFF 'D' OR 'E' IF EXPONENT IS TOO BIG. IMPLEMENTED S,SP,SS,BN,BZ FORMATS, AS WELL AS Iw.m AND Ow.m. MOVED ALL FREE-FORMAT HANDLING (SCANNING FOR DELIMITERS, ETC) OUT OF CONVERSION ROUTINES INTO THE FORMAT PROCESSOR, NAMELIST/LDIO, AND %SKIP. ???? ??? ??-???-80 Q10-04560 FIXED ERROR CALL IN NAMELIST/LDIO AT SETNUL. SHOULD HAVE BEEN %ILCHR, WAS %ILCH1, ARROW WAS OFF BY 1. 1153 JLC 9-Sep-80 --------- SPED UP ALPHI/ALPHO BY REMOVING SOME COMMON CODE, REMOVING CALL TO %SAVE2. 1154 JLC 9-Sep-80 --------- FIX TO INTI FOR OVERFLOW - OUTPUTS OVERFLOW MSG AND SETS VALUE TO HIGHEST INTEGER. 1155 JLC 9-Sep-80 --------- FIX FLOUT TO TURN OFF BIT 0 OF 2ND WORD TO PREVENT INTEGER OVERFLOWS FROM FLOUT. 1156 JLC 26-Sep-80 --------- NAMELIST WAS NOT INSISTING ON BEGINNING '$' BEING IN COLUMN 2 AFTER SKIPPING DATA. IT WAS ALSO EATING THE BEGINNING '$' OF A NAMELIST WHILE TRYING TO READ THROUGH GARBAGE RECORDS IF THE GARBAGE HAD A ENDING '$' FROM A PREVIOUS ABORTIVE NAMELIST READ 1163 JLC 23-Oct-80 --------- FIXED R-FORMAT INPUT 1172 JLC 2-Dec-80 Q20-01318 DPFLG WAS NOT GETTING CLEARED IN ALPHI/ALPHO. 1314 EDS 4-Mar-81 Q20-01392 Change NAMELIST input to ignore anything in column 1 of the data stream under a feature test switch FTNLC1. Change NAMELIST output to terminate with $END. 1347 DAW 16-Mar-81 Patch to allow FLIRT. to run in extended addressing, also changes to list-directed I/O routines. 1371 JLC 27-Mar-81 Make zero-trip I/O loops work for list-directed I/O 1440 DAW 17-Apr-81 Some extended addressing support. 1446 DAW 22-Apr-81 Rework NMLST code to not smash P4 in a lower-level routine; fixes bug caused by edit 1440. 1464 DAW 12-May-81 Error messages. 1470 CKS 22-May-81 Q20-1360 Fix overflow in FLOUT. Incrementing double integer didn't check for carry between words. 1514 JLC 8-Jun-81 Fix several bugs in NAMELIST code (subscript out of range), added code to accept rest of array if data specifies array reference, fixed column 1 skip feature test code. 1521 JLC 26-Jun-81 Change EOF processing so it doesn't use D%EOF to check. Instead check D%END and IRCNT(D).LE.0. 1522 JLC 01-Jul-81 Fix R format output to match R format input. For width greater than 5, bit 0 of low-order word is still 0, and excess characters are right justified in the high-order word. 1532 DAW 14-Jul-81 OPEN rewrite: Base level 1 1557 JLC 24-Jul-81 FLOUT uses double precision for everything. Therefore output the same number of digits maximum (20) if the program asks for them. 1560 DAW 28-Jul-81 OPEN rewrite: Base level 2 1606 DAW 13-Aug-81 Fix right-justified output of one-word items. 1625 DAW 21-Aug-81 Get rid of "DF". 1626 DAW 24-Aug-81 Change AC names in FLIRT and FLOUT so "D" is not defined there. 1644 JLC 27-Aug-81 Make free-format A stop on comma. Change R*C to be R*C, at least for version 6. Leave code to make it R*,C in repeat 0 in case the ANSI Committee makes a firm decision. 1662 DAW 4-Sep-81 %CALU; user error handling routine. 1710 JLC 14-Sep-81 Fixed problems with delimiter in namelist/ldio. 1733 BL 22-Sep-81 Problem finding beginning of NAMELIST. 1736 JLC 23-Sep-81 Fix to edit 1733. 1740 JLC 23-Sep-81 Added check for legal delimiter at end of scan for namelist and list-directed I/O. 1745 JLC 24-Sep-81 Fixed "r*,", was skipping over the comma. 2014 AHM/JLC 19-Oct-81 Number of dimensions in a NAMELIST is now bits 2-8 for extended addressing compatability. Fixed illegal (too big) subscript in NAMELIST to give error. 2016 JLC 20-Oct-81 Remove temporary one-trip in LDSET, now fixed in SLIST and ELIST. 2021 JLC 22-Oct-81 Change ALPHI to substitute 5 or 10 for field width of 0, required by ANSI standard. 2024 DAW 26-Oct-81 Make $ECALL ILC return to %ABORT - it's a fatal error now. 2032 JLC 29-Oct-81 Fix KI code for DPMUL. 2033 JLC 19-Nov-81 Pad R-format with spaces instead of nulls (like V5A). Make ILS error go to %ABORT if no ERR= branch. ***** Begin Version 6A ***** 2037 DAW 21-Dec-81 NAMELIST input runs too slowly if a large array is read one element at a time. ***** Begin Version 7 ***** 3002 JLC 23-Oct-81 Add character I/O to ALPHI and ALPHO. 3004 JLC 27-Oct-81 Fix ALPHI - was not blank-filling character variables. 3010 JLC 2-Nov-81 Merged fix from V6. 3012 JLC 4-Nov-81 Fix character I/O for SLISTS - use some new parameters. 3017 AHM 6-Nov-81 Make NAMELIST I/O assume that the address of the NAMELIST block was specified by an immediate argument. 3023 JLC 15-Nov-81 Various V6 patches: blank-fill for R-format output, %ABORT call after illegal subscript in NAMELIST. 3036 BL 10-Feb-82 Inserted code for list-directed I/O for character strings. 3040 JLC 11-Feb-82 Make 0 written with G-format 0.000000E+00, as the ANSI Standard says so. 3044 BL 19-Feb-82 Put NLCPTR in DATA, where it belongs. Initialize properly in NLINIT. 3045 BL 23-Feb-82 Really initialize properly. see #3044. 3050 BL 25-Feb-82 Install changes from code review (NAMELIST & LISTDIRECTED character I/O. 3056 JLC 23-Mar-82 Separate FORCNV into FORCNV and FORNML (namelist and list-directed I/O). Inserted floating overflow and underflow messages in FLIRT. 3075 JLC 31-Mar-82 Fix overflow/underflow messages in FLIRT and INTI. 3122 JLC 28-May-82 Change error message calls, make FTAST a switchable flag instead of an assembly parameter. 3126 JLC 7-Jun-82 Remove substitution of blank for null in ALPHO. 3136 JLC 26-Jun-82 Performance work, fix GFLOAT bug in FLIRT which got overflow or underflow results for legal GFLOAT numbers in LDIO. 3143 AHM 6-Jul-82 Correct AC field of the XBLT at ALPBLT-3L that sets extended hollerith arrays to spaces before doing input. 3144 AHM 6-Jul-82 Mend fencepost at ALPBLT-3L which cleared one location too many in the user's array with an XBLT. 3150 JLC 13-Jul-82 Fixed INTO so it leaves the user's specification of minimum number of digits for G-format. 3154 JLC 20-Jul-82 Fix input of G-float numbers. 3165 JLC 28-Aug-82 Fix INTI, OCTI, and HEXI so that free format read of just a sign returns 0 and does not go into infinite loop. 3166 JLC 30-Aug-82 Fix to edit 3165 - minus signs were giving Illegal char in data. 3171 JLC 1-Sep-82 Fix integer input, as edits 3165 and 3166 were slightly off. 3202 JLC 26-Oct-82 Eliminate double printing of overflow message if exponent too large in FLIRT. 3203 JLC 31-Oct-82 Fix SPCWD problem. 3253 JLC 12-Jan-83 Fix %SKIP so it actually skips past end of record. Otherwise %SFDEL backs up over a real character. ***** End V7 Development ***** 3273 JLC 21-Feb-83 Print * if the exponent including the E does not fit into the specified format. Also, when SP is specified, print * if the + sign does not fit into the specified format. 3302 TGS 05-Mar-83 Exponent-width check in Edit 3273 trashes AC2, can fail for Gfloat numbers with no exponent specified. 3342 TGS 16-Aug-83 SPR:10-34005 Input of double-precision octal numbers whose high-order word is all zero will in effect swap words, placing the significant digits in the high-order word on output. ***** Begin Version 10 **** 4010 JLC 14-Apr-83 Enlarge the power of ten table so that non-gfloat numbers will never have to do more than 1 scaling multiplication. Modify FLIRT and FLOUT accordingly. 4016 JLC 22-Jun-83 Put SEGMENT CODE before PRGEND so literals will be in high segment. 4023 JLC 29-Jun-83 Make overflows and underflows user-fixable. Use global variables for BZ and SP format flags. 4034 JLC 19-Jul-83 Remove extraneous, erroneous instruction from OCTO field width overflow code. 4036 JLC 3-Aug-83 Make "field width too small" asterisks user-modifiable, by providing a character descriptor pointing to the asterisks in the FOROTS record buffer. 4043 JLC 15-Sep-83 Move FLIRT, INTI/INTO, HEXI/HEXO, OCTI/OCTO and POWTB to MTHLIB. 4111 JLC 15-Mar-84 Changed the default leading zero output to LZALWAYS. 4113 JLC 23-Mar-84 Fix LZALWAYS, did not mix well with SP format. 4166 MRB 15-NOV-84 Change the way ALPNIN was creating a word of spaces. It was under the impresstion that the internal bite-size was the same as the external byte-size. Internal bytesize is always 7. 4201 JLC 29-Jan-85 Fix FLOUT so that -1PE10.1 "works": it used to output an extra zero after the decimal point. Insert some code to handle rounding up the zero preceding the decimal point if there are no trailing digits. ***** End V10 Development ***** ***** End Revision History ***** \ PRGEND TITLE ALPHA ALPHANUMERIC INPUT/OUTPUT ROUTINES SUBTTL D. TODD/DRT/HPW/MD 28-Oct-81 SEARCH MTHPRM,FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987 ;ALL RIGHTS RESERVED. ;FROM LIB40 %4(354) SEGMENT CODE ENTRY %ALPHI,%ALPHO,%RIGHI,%RIGHO EXTERN %IBYTE,%OBYTE,%FWVAL EXTERN IO.ADR,IO.SIZ,IO.TYP,%SAVE2 EXTERN %SIZTB,%IMBYT,%OMBYT,%OMSPC EXTERN %CIPOS,IO.INS,IO.NUM,IO.INC,ENC.LR DPFLG==1 %ALPHI: MOVE T1,IO.TYP ;GET DATA TYPE CAIE T1,TP%CHR ;CHARACTER? JRST ALPNIN ;NO. NUMERIC PUSHJ P,ALPCHR ;DO CHARACTER SETUP MOVE T1,ALPSIZ ;USE FULL ENTRY SIZE, AS FILL IS NEEDED MOVEM T1,ALPBYT AICOM: MOVE T2,ALPSIZ ;GET FULL ENTRY SIZE IN BYTES MOVE T1,ALPWID ;GET FORMAT WIDTH CAMG T1,T2 ;WIDTH .GT. SIZE? JRST AIMAT ;NO. GO MOVE AND FILL SUB T1,T2 ;GET # CHARS TO SKIP PUSHJ P,%CIPOS ;SKIP THEM MOVE T0,ALPBYT ;USE DEST COUNT FOR LEFTOVER SOURCE COUNT JRST AIMOVE AIMAT: MOVE T0,ALPWID ;GET # CHARS TO TRANSFER AIMOVE: MOVE T3,ALPBYT ;GET DESTINATION SIZE MOVE T4,ALPNTR ;AND DEST POINTER PUSHJ P,%IMBYT ;MOVE THE STRING SKIPN T1,ALPLI ;ANY LOCAL INCREMENT? JRST AINLI ;NO XCT ALPINS ;YES. INCREMENT THE POINTER MOVEM T1,ALPNTR ;SAVE IT BACK SOSLE ALPLC ;DECR LOCAL COUNT JRST AICOM ;MORE TO GO AINLI: SKIPN T1,ALPINC ;GET TOTAL INCREMENT POPJ P, ;NONE XCT IO.INS ;INCREMENT DATA POINTER MOVEM T1,IO.ADR ;SAVE IT BACK MOVN T1,ALPNEN ;GET NUMBER OF EXTRA ENTRIES PROCESSED ADDM T1,IO.NUM ;DECR NUMBER ENTRIES ADDM T1,ENC.LR ;DECR FORMAT REPEAT COUNT POPJ P, ALPNIN: PUSHJ P,ALPNUM ;SET VARIABLES FOR NUMERIC ENTRIES MOVE T1,ALPSIZ ;GET DESTINATION SIZE CAMLE T1,ALPWID ;BIGGER THAN FORMAT WIDTH? MOVE T1,ALPWID ;YES. USE WIDTH MOVEM T1,ALPBYT ;AS # INPUT BYTES, AS NO PAD NEEDED MOVE T1,[ASCII/ /] ;[4166]GET A WORD OF SPACES MOVEM T1,@IO.ADR ;INITIALIZE 1ST DATA WORD MOVE T2,ALPNEL ;GET # WORDS TO INIT CAIG T2,1 ;MORE THAN 1? JRST AICOM ;NO. JUST MOVE THE STRING MOVE T3,IO.ADR ;YES. GET THE SOURCE ADDR TLNN T3,-1 ;NON-ZERO SECTION? JRST ALPBLT ;NO. USE STANDARD BLT SUBI T2,1 ;[3144] One word has already been cleared XMOVEI T4,1(T3) ;DEST IS C(IO.ADR)+1 EXTEND T2,[XBLT] ;[3143] Init the array JRST AICOM ;JOIN COMMON CODE ALPBLT: ADDI T2,(T3) ;GET FINAL ADDR+1 HRLI T3,(T3) ;GET SOURCE ADDR ADDI T3,1 ;GET DEST ADDR BLT T3,-1(T2) ;INIT THE ARRAY JRST AICOM %ALPHO: MOVE T1,IO.TYP ;GET DATA TYPE CAIN T1,TP%LIT ;LITERAL STRING? JRST ALPLOU ;YES. TAKE THE SLOW BOAT CAIE T1,TP%CHR ;CHARACTER? JRST ALPNOU ;NO. NUMERIC ALPCOU: PUSHJ P,ALPCHR ;DO CHARACTER SETUP AOCOM: MOVE T2,ALPSIZ ;GET ENTRY SIZE MOVE T3,ALPWID ;GET FORMAT WIDTH CAMG T3,T2 ;WIDTH .GT. SIZE? JRST AOTRUN ;NO. GO MOVE AND TRUNCATE IF NECESSARY SUB T3,T2 ;GET # CHARS TO SKIP PUSHJ P,%OMSPC ;FILL WITH SPACES MOVE T0,ALPSIZ ;AND PROCEED WITH MOVING STRING JRST AOMOVE AOTRUN: MOVE T0,ALPWID ;USE FORMAT WIDTH AOMOVE: MOVE T1,ALPNTR ;GET DATA POINTER PUSHJ P,%OMBYT ;MOVE STRING SKIPN T1,ALPLI ;ANY LOCAL INCREMENT? JRST AONLI ;NO XCT ALPINS ;YES. INCREMENT THE POINTER MOVEM T1,ALPNTR ;SAVE IT BACK SOSLE ALPLC ;DECR LOCAL COUNT JRST AOCOM ;MORE TO GO AONLI: SKIPN T1,ALPINC ;GET TOTAL INCREMENT POPJ P, ;NONE XCT IO.INS ;INCREMENT DATA POINTER MOVEM T1,IO.ADR ;SAVE IT BACK MOVN T1,ALPNEN ;GET NUMBER OF EXTRA ENTRIES PROCESSED ADDM T1,IO.NUM ;DECR NUMBER ENTRIES ADDM T1,ENC.LR ;DECR FORMAT REPEAT COUNT POPJ P, ALPNOU: PUSHJ P,ALPNUM ;SETUP FOR NUMERIC DATA JRST AOCOM ;JOIN COMMON CODE ;LITERAL OUTPUT - SCAN THE SOURCE STRING FOR A NULL, COUNTING ;THE CHARACTERS. THEN CREATE A STRING DESCRIPTOR, AND JOIN THE ;CHARACTER CODE ABOVE. ALPLOU: MOVE T1,IO.ADR ;GET ADDRESS $BLDBP T1 ;BUILD A BYTE POINTER TO IT MOVEM T1,IO.ADR ;SAVE IT BACK FOR LATER SETZ T2, ;CLEAR A CHAR COUNT LOULP: ILDB T3,T1 ;GET A CHAR JUMPE T3,LOUEND ;NULL. WE'RE DONE COUNTING AOJA T2,LOULP ;NOT. COUNT IT LOUEND: MOVEM T2,IO.SIZ ;SAVE SIZE JRST ALPCOU ;GO TO CHARACTER OUTPUT ALPCHR: MOVE T1,IO.SIZ ;GET ENTRY SIZE MOVEM T1,ALPSIZ ;SAVE IT PUSHJ P,CHKOPT ;CHECK FOR POSSIBLE OPTIMIZATIONS MOVE T1,IO.ADR ;GET BYTE PNTR MOVEM T1,ALPNTR ;SAVE IT MOVE T1,[ADJBP T1,ALPNTR] ;GET PNTR INCR INSTRUCTION MOVEM T1,ALPINS ;SAVE IT FOR LOOP POPJ P, ALPNUM: MOVE T1,IO.SIZ ;GET ENTRY SIZE IN WORDS IMULI T1,IBPW ;GET IT IN BYTES MOVEM T1,ALPSIZ ;SAVE IT PUSHJ P,CHKOPT ;CHECK FOR POSSIBLE OPTIMIZATIONS MOVE T1,IO.ADR ;GET DATA ADDR $BLDBP T1 ;BUILD A BYTE POINTER MOVEM T1,ALPNTR ;SAVE IT MOVE T1,[ADD T1,ALPNTR] ;GET ADDR INCR INSTRUCTION MOVEM T1,ALPINS ;SAVE IT FOR LOOP POPJ P, CHKOPT: MOVE T1,%FWVAL ;GET FORMAT WIDTH JUMPN T1,GOTAWD ;DEFAULT TO ENTRY SIZE IF ZERO MOVE T1,ALPSIZ GOTAWD: MOVEM T1,ALPWID ;SAVE IT MOVE T1,IO.SIZ ;GET ELEMENT SIZE CAME T1,IO.INC ;SAME AS INCREMENT? JRST NOOPT ;NO. SHOULDN'T OPTIMIZE MOVE T1,IO.NUM ;GET # ENTRIES BEING PROCESSED CAIG T1,1 ;USEFUL TO OPTIMIZE? JRST NOOPT ;NO MOVE T2,ENC.LR ;GET # ENTRIES FOR THIS FORMAT ATOM CAIG T2,1 ;USEFUL TO OPTIMIZE? JRST NOOPT ;NO CAMLE T1,T2 ;GET SMALLER OF THE TWO MOVE T1,T2 MOVEM T1,ALPLC ;SAVE AS LOCAL ENTRY COUNT SUBI T1,1 ;CALC # EXTRA ENTRIES BEING PROCESSED MOVEM T1,ALPNEN ;SAVE IT IMUL T1,IO.SIZ ;GET # WORDS/CHARS TO COMBINE MOVEM T1,ALPINC ;SAVE TOTAL INCREMENT ADD T1,IO.SIZ ;RESTORE TO FULL ELEMENT COUNT MOVEM T1,ALPNEL ;SAVE # WORDS/CHARS MOVE T1,ALPWID ;GET FORMAT WIDTH CAME T1,ALPSIZ ;SAME AS ELEMENT SIZE? JRST OPTONE ;NO. ONE BY ONE CASE MOVE T1,ALPLC ;GET # ENTRIES AGAIN IMULB T1,ALPWID ;CALCULATE # CHARS, MAKE IT WIDTH MOVEM T1,ALPSIZ ;SAVE AS HUGE SIZE SETZM ALPLI ;NO LOCAL INCREMENT SETZM ALPLC ;NO LOCAL COUNT POPJ P, OPTONE: MOVE T1,IO.INC ;USE GIVEN INCREMENT MOVEM T1,ALPLI ;AS LOCAL ONE POPJ P, NOOPT: SETZM ALPNEN ;NO EXTRA ENTRIES BEING PROCESSED SETZM ALPINC ;NO TOTAL INCREMENT SETZM ALPLC ;NO LOCAL COUNT SETZM ALPLI ;AND NO LOCAL INCREMENT MOVE T1,IO.SIZ ;GET # ELEMENTS/ENTRY MOVEM T1,ALPNEL ;SAVE AS WORDS/CHARS PROCESSED POPJ P, ;ROUTINES TO RIGHT JUSTIFY ASCII STRING IN THE USER'S NUMERIC VARIABLE ;CHARACTER VARIABLES ILLEGAL %RIGHI: PUSHJ P,ALPSET ;DO GENERAL SETUP MOVE T2,IO.ADR ;GET THE VARIABLE ADDR JUMPG T5,RI1 ;WIDTH SPECIFIED MOVEI T5,(T4) ;NO-SET DEFAULT RI1: SUBI T4,(T5) ;GET NEG FILL NEEDED JUMPGE T4,RIGHI1 ;NO SKIP IF .GE. 0 ADD T5,T4 ;THERE IS FILL. SET WIDTH TO MAX DEFAULT RIGHI0: PUSHJ P,%IBYTE ;EXCESS W SKIP INPUT CHARACTERS AOJL T4,RIGHI0 ;CONTINUE SKIPPING RIGHI1: SETZB T3,T4 ;CLEAR THE RECEIVING WORD RIGHI2: LSHC T3,^D7 ;SHIFT A CHARACTER PUSHJ P,%IBYTE ;READ A CHARACTER IOR T4,T1 ;INSERT THE CHARACTER SOJG T5,RIGHI2 ;CONTINUE LSHC T3,1 ;CLEAR THE LOW ORDER SIGN BIT LSH T4,-1 ;AND POSITION MOVEM T4,(T2) ;STORE THE LOW ORDER WORD (SINGLE) TXNE F,DPFLG ;DOUBLE PRECISION? DMOVEM T3,(T2) ;STORE BOTH WORDS (DOUBLE) POPJ P, ;RETURN %RIGHO: PUSHJ P,ALPSET ;DO GENERAL SETUP SETZ T2, ;CLEAR HIGH ORDER WORD MOVE T3,@IO.ADR ;GET LOW WORD TXNE F,DPFLG ;BUT IF DOUBLE PRECISION DMOVE T2,@IO.ADR ;GET BOTH WORDS LSH T3,1 ;PUSH LOW WORD TO BIT 0 TXNE F,DPFLG ;If double-precision, LSHC T2,1 ;PUSH BOTH WORDS TO BIT 0 JUMPG T5,RO1 ;SPECIFIED MOVEI T5,(T4) ;NO-SET DEFAULT RO1: SUBI T4,(T5) ;GET NEG FILL NEEDED ;Note: T5= # chars to output ; T4= 0 if output (T5) chars ; T4= positive if first chars must be skipped ; T4= negative if not enough chars (pad with spaces) JUMPGE T4,INCPT ;IF NO FILL, TRY SKIP ADD T5,T4 ;SET DATA WIDTH TO DEFAULT MOVEI T1," " ;OUTPUT SPACES FOR SKIP WIDTH RIGHO1: PUSHJ P,%OBYTE ;OUTPUT THE SPACE AOJL T4,RIGHO1 ;LOOP FOR SKIP WIDTH INCPT: JUMPLE T4,ROLP1 ;IF NO SKIP, GO OUTPUT CHARS RIGHO2: LSHC T2,7 ;TOSS THE CHARACTER SOJG T4,RIGHO2 ROLP1: TXNN F,DPFLG ;If single precision, MOVE T2,T3 ;Get correct word to output ROLP2: ROTC T2,7 ;ROTATE CHAR INTO T3 MOVEI T1,(T3) ;COPY THE CHAR (WITH TRASH) ANDI T1,177 ;TOSS THE TRASH RONN: PUSHJ P,%OBYTE ;OUTPUT THE CHAR SOJG T5,ROLP2 POPJ P, ;RETURN TO FOROTS ;Routine to setup for alphabetic conversions ALPSET: MOVEI T4,5 ;ASSUME SINGLE PRECISION MOVE T5,%FWVAL ;GET THE WIDTH FIELD MOVE T1,IO.TYP ;GET THE VARIABLE TYPE MOVE T1,%SIZTB(T1) ;GET ENTRY SIZE ASH T4,-1(T1) ;IF DP, MUL # CHARS BY 2 CAIN T1,2 ;DOUBLE? TXOA F,DPFLG ;YES. SET FLAG TXZ F,DPFLG ;NO. CLEAR IT POPJ P, SEGMENT DATA ALPLI: BLOCK 1 ;LOCAL PNTR INCREMENT ALPLC: BLOCK 1 ;LOCAL ENTRY COUNT ALPNEN: BLOCK 1 ;NUMBER OF EXTRA ENTRIES PROCESSED ALPINS: BLOCK 1 ;LOCAL PNTR INCREMENT INSTRUCTION ALPINC: BLOCK 1 ;LOCAL INCREMENT ALPNEL: BLOCK 1 ;# WORDS OR CHARS BEING PROCESSED ALPSIZ: BLOCK 1 ;LOCAL ENTRY SIZE IN BYTES ALPBYT: BLOCK 1 ;FOR INPUT, # CHARS TO TRANSFER ALPWID: BLOCK 1 ;LOCAL FORMAT WIDTH ALPNTR: BLOCK 1 ;BYTE POINTER TO VARIABLE SEGMENT CODE PRGEND TITLE FLOUT FLOATING POINT OUTPUT SUBTTL D. NIXON AND T. W. EGGERS SUBTTL D. TODD /DMN/DRT/HPW/MD/JNG/CLRH/CYM 28-Oct-81 SUBTTL JLC - VERSION 6 SEARCH MTHPRM,FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987 ;ALL RIGHTS RESERVED. SEGMENT CODE AC0==T0 ;FLOATING POINT NO. ON ENTRY AC1==T1 ;USED IN FORMING DIGITS AC2==T2 ;DITTO. D.P. ONLY AC3==T3 ;EXTENDED EXPONENT ONLY AC4==T4 AC5==T5 C==T4 ;CNTR./NO. OF CHARS BEFORE DEC. POINT XP==T5 ;DECIMAL EXPONENT SF==P4 ;SCALE FACTOR NUMSGN==1 ;NEGATIVE NUMBER NOSIGN==4 ;NO SPACE FOR + SIGN EQZER==10 ;ITEM IS IDENTICALLY ZERO DPFLG==20 ;VARIABLE IS DOUBLE PRECISION EEFLG==40 ;VARIABLE IS EXTENDED EXPONENT DOUBLE PRECISION NOEFLG==100 ;DO NOT PRINT "D" OR "E" IN EXPONENT NOPNT==200 ;DO NOT PRINT THE DECIMAL POINT (FOR FTAST=0) LOCFLG==NUMSGN+NOSIGN+EQZER+DPFLG+EEFLG+NOEFLG SPMAX==^D20 DPMAX==^D20 ;MAXIMUM NUMBER OF DIGITS TO PRINT ;IF WE PRINT ANY MORE, WE WILL BE LYING TO THE ;USER, AS THIS IS THE MAXIMUM PRECISION OF ;OUR SCALING FACTORS OF 10. ;WE CANNOT KNOW WHETHER THE NUMBER WE ;HAVE IN THE MACHINE IS AN EXACT REPRESENTATION ;OF WHATEVER WAS INPUT - WE MUST ASSUME THAT ;WHAT IS IN THE MACHINE IS EXACTLY WHAT IS DESIRED. ;THEREFORE THERE IS NO REASON NOT TO GIVE AS MANY ;DIGITS AS ARE ACCURATE. THE ONLY LIMITATION ON ;THIS CURRENTLY IS THE SCALING ALGORITHM. LZALWAYS==1 ;SWITCH FOR ALWAYS PRINTING LEADING ZEROES LZSOME==0 ;SWITCH FOR SOMETIMES - ALWAYS EXCEPT WHEN ;POSITIVE NUMBER IS PRINTED WITH ONLY ONE LEADING ;SPACE ENTRY %FLOUT,%DOUBT,%GROUT,%EOUT ENTRY %EEMUL,%EEDIV,%EENRM EXTERN %OBYTE,%EXP10,%HITEN,%LOTEN,%PTMAX EXTERN %FWVAL,%DWVAL,%XPVAL EXTERN IO.ADR,IO.TYP,%FLINF,%SCLFC,%SAVE4,%FTAST,%FTSLB,%SPFLG EXTERN %SIZTB,%BEXP,%DEXP,%PMEXP EXTERN %FTSUC ;INSTEAD OF HAVING MANY GLOBAL FLAGS PASSED TO FLOUT, THERE ARE ;SEVERAL ENTRY POINTS WHICH SET FLAGS LOCAL TO THE ROUTINE. %DOUBT: TXZ F,F%GTP+F%ETP ;NOT G OR E FORMAT TXO F,F%DTP ;FLAG TO PRINT A "D" JRST REALO %GROUT: TXZ F,F%DTP+F%ETP ;TRY WITHOUT SCIENTIFIC NOTATION TXO F,F%GTP JRST REALO %EOUT: TXZ F,F%GTP+F%DTP ;TURN OFF THE OTHER FLAGS TXO F,F%ETP ;FLAG TO PRINT AN "E" JRST REALO %FLOUT: TXZ F,F%GTP+F%ETP+F%DTP REALO: PUSHJ P,%SAVE4 ;SAVE P1-P4 TXZ F,LOCFLG ;CLEAR LOCAL FLAGS IN F MOVE AC1,IO.TYP ;GET VARIABLE TYPE MOVE AC2,%SIZTB(AC1) ;GET ENTRY SIZE CAIN AC2,2 ;IS VARIABLE DOUBLE PRECISION? TXO F,DPFLG ;YES. SET FLAG CAIN AC1,TP%DPX ;EXTENDED EXPONENT? TXO F,EEFLG ;YES. SET FLAG MOVE AC2,IO.ADR ;GET VARIABLE ADDR MOVE AC0,(AC2) ;LOAD AC 0 WITH NUMBER SETZ AC1, ;CLEAR LOW WORD TXNE F,DPFLG ;DOUBLE PRECISION? MOVE AC1,1(AC2) ;YES, GET LOW WORD ALSO TLZ AC1,(1B0) ;ELIMINATE GARBAGE SIGN BIT SETZ XP, ;CLEAR EXPONENT JUMPGE AC0,FLOUT1 ;NUMBER NEGATIVE? DMOVN AC0,AC0 ;YES. NEGATE IT TXO F,NUMSGN ;AND - SET SIGN FLAG ;THE INTENTION IN THE CODE FOLLOWING IS TO LEFT-JUSTIFY THE MANTISSA ;AFTER EXTRACTING THE BINARY EXPONENT, AND THEN TO "SCALE" THE NUMBER ;BY ONE OR MORE POWERS OF TEN SO THAT IT ENDS UP WITH VALUE LESS ;THAN 1.0 BUT GREATER THAN OR EQUAL TO 0.1, KEEPING TRACK OF THE ;POWERS OF TEN USED IN THE SCALING PROCESS. THESE POWERS OF TEN ;ARE ACCUMULATED INTO A DECIMAL EXPONENT, KEPT IN XP. ; ;EXTENDED EXPONENT NUMBERS WHICH REQUIRE A HUGE POWER OF TEN TO SCALE ;THEM DOWN (OR UP) ARE FILTERED THROUGH A SPECIAL ROUTINE WHICH USES ;A SPARSE POWER OF TEN TABLE TO BRING THE NUMBER INTO THE "NORMAL" ;RANGE. FLOUT1: JUMPN AC0,FLONZ ;OK IF NON-ZERO JUMPE AC1,FLOUT6 ;ZERO IF BOTH ZERO FLONZ: TXNN F,EEFLG ;EXTENDED EXPONENT? JRST FLOU1A ;NO PUSHJ P,EEDEC ;YES. HANDLE SEPARATELY JRST FLOUT2 FLOU1A: HLRZ P1,AC0 ;EXTRACT EXPONENT LSH P1,-9 HRREI P1,-200(P1) ;EXTEND SIGN TLZ AC0,777000 ;GET RID OF HIGH EXP FLOUT2: ADDI P1,^D8 ;EXPONENT IS 8 BIGGER ON NORM MOVE AC3,AC0 ;GET THE HI FRACTION JFFO AC3,FLOU2A ;GET HI BIT EXCH AC0,AC1 ;NONE. SWAP LO AND HI SUBI P1,^D35 ;AND DECR BINARY EXPONENT MOVE AC3,AC0 ;GET NEW HI WORD JFFO AC3,FLOU2A ;GET HI BIT JRST FLOUT6 ;NUMBER IS ZERO FLOU2A: ASHC AC0,-1(AC4) ;NORMALIZE NUMBER SUBI P1,-1(AC4) ;AND MODIFY BINARY EXPONENT FLOU2B: MOVE P2,P1 ;GET BINARY EXPONENT IMULI P2,232 ;DEC EXP=LOG10(2)*BIN EXP=.232(OCTAL)*BIN EXP ADDI P2,400 ;ROUND TO NEAREST INTEGER ASH P2,-^D9 ;GET RID OF 3 OCTAL FRACTION DIGITS ;THE ABOVE WORKS FOR NEGATIVE EXPONENTS BECAUSE ;THE ASH TRUNCATION EFFECTIVELY ;ROUNDS UP IN THE NEGATIVE DIRECTION ;FOR NEGATIVE VALUES ;P2 HOLDS A FIRST TRIAL DECIMAL EXPONENT. IT MAY BE ;ONE (BUT NO MORE) TOO SMALL TO DIVIDE THE BINARY NUM ;BY TO GET THE RANGE 1.0 .GT. NUM .GE. 0.1 FLOUT3: MOVE P3,%EXP10(P2) ;GET BIN EXP THAT MATCHES DEC EXP CAMLE P3,P1 ;FRACTION .GT. POWER OF 10? JRST FLOT4A ;YES CAME P3,P1 AOJA P2,FLOT4A ;NOT IN EXPONENT CAMGE AC0,%HITEN(P2) ; JRST FLOT4A ;YES, IN HIGH FRACTION CAMN AC0,%HITEN(P2) CAML AC1,%LOTEN(P2) ADDI P2,1 ;NO, IN FRACTION PART FLOT4A: PUSHJ P,DPMUL ;SCALE BY POWER OF 10 ASHC AC0,(P1) ;SCALE BY ANY REMAINING POWERS OF 2 TLO T1,(1B0) ;PREVENT OVERFLOW ADDI T1,1 ;ROUND IT UP SOME MORE TLZN T1,(1B0) ;CARRY INTO SIGN? ADDI T0,1 ;YES, PROPAGATE TO HIGH WORD FLOUT6: MOVE C,%FWVAL MOVE T3,%DWVAL HRRE SF,%SCLFC ;GET THE SCALING FACTOR JUMPN AC0,FLOU6A ;IS NUMBER ZERO? TXO F,EQZER ;YES. SET FLAG TXZ F,NUMSGN ;AND CLEAR ANY SIGN! SETZ XP, ;AND THE EXPONENT! FLOU6A: JUMPN C,FLOUT7 TXNE F,DPFLG ;DOUBLE PRECISION? ADDI C,1 ;YES, INCREMENT INDEX INTO TABLE HRRZ T3,FRMTAB(C) ;PICKUP DEFAULT FORMAT FOR DECIMAL WIDTH HLRZ C,FRMTAB(C) ;SAME FOR WIDTH ;HERE IS THE FIRST G-FORMAT NUMBER FILTER. THE NUMBER IS CHECKED ;IF IT IS "PROPER MAGNITUDE" FOR G-FORMAT. IF THE MAGNITUDE OF THE ;NUMBER IS SMALLER THAN 10**D OR GREATER THAN OR EQUAL TO 0.1, ;THE NUMBER SHOULD BE PRINTED IN F-FORMAT. SINCE THE NUMBER HAS NOT ;BEEN ROUNDED YET, WE CHECK THE NUMBER JUST USING THE DECIMAL EXPONENT XP, ;AND ALLOW NUMBERS WITH XP GREATER THAN -1 (WHICH COULD INCLUDE ;NUMBERS LESS THAN 0.1). A SECOND CHECK IS DONE AT CHKRND, AFTER ;THE NUMBER HAS BEEN ENCODED, TO SEE IF ROUNDING FORCED THE NUMBER ;INTO OR OUT OF THE F-FORMAT RANGE. FLOUT7: TXNN F,F%GTP ;G TYPE CONVERSION? JRST FLOUT8 ;NO TXNE F,EQZER ;NUMBER ZERO? JRST CETYP ;YES. ANSI STANDARD SAYS IT'S E-FORMAT! CAML XP,[-1] ;IF EXPONENT .LT. 1 CAMLE XP,T3 ;OR .GT. # DECIMAL PLACES CETYP: TXOA F,F%ETP ;SET E CONVERSION JRST FLOUT8 ;NOT E, JUMP ;HERE WE FIGURE OUT HOW MANY SIGNIFICANT DIGITS TO GET FROM THE ;NUMBER. FOR G-FORMAT, THIS IS JUST "D" (AS IN W.D). FOR D AND ;E-FORMATS, IT DEPENDS ON THE SCALE FACTOR. FOR SCALE FACTORS ;LESS THAN ZERO, THE NUMBER OF DIGITS IS REDUCED BY THE SCALE ;FACTOR. FOR POSITIVE SCALE FACTORS, THE NUMBER OF DIGITS IS ;INCREASED BY ONE, UNLESS THE SCALE FACTOR IS MORE ;THAN ONE LARGER THAN THE NUMBER OF DECIMAL PLACES, IN WHICH ;CASE THE NUMBER OF DIGITS IS SET TO THE SCALE FACTOR ALONE. ;FOR F-FORMAT, THE SIZE OF THE NUMBER (DECIMAL EXPONENT) IS ;ADDED TO THE NUMBER OF DIGITS IN ADDITION TO THE SCALE ;FACTOR. FLOUT8: MOVE P2,T3 ;GET # DECIMAL PLACES TXNN F,F%ETP!F%DTP ;D OR E FORMAT? JRST FLOU8A ;NO JUMPLE SF,FLOUT9 ;IF NEG, JUST GO ADD SCLFCT CAILE SF,1(T3) ;WITHIN DEFINED RANGE? MOVEI P2,-1(SF) ;NO. SET TO SCLFCT ADDI P2,1 ;YES. JUST ADD 1 JRST FLOU10 FLOU8A: TXNE F,F%GTP ;G-FORMAT? JRST FLOU10 ;YES. WE'RE ALL DONE ADD P2,XP ;NO. ADD MAGNITUDE OF NUMBER FLOUT9: ADD P2,SF ;ADD SCLFCT TO # DIGITS DESIRED FLOU10: JUMPN AC0,FLO10A ;IF NUMBER IS ZERO SETZ P2, ;DON'T ENCODE ANY DIGITS FLO10A: CAILE P2,DPMAX ;TOO MANY DECIMAL PLACES MOVEI P2,DPMAX ;YES, REDUCE TO MAX POSSIBLE TXNE F,DPFLG ;DOUBLE PRECISION? JRST DIGOK ;YES CAILE P2,SPMAX ;NO. RESTRICT TO SPMAX MOVEI P2,SPMAX DIGOK: MOVE P1,P ;MARK BOTTOM OF DIGIT STACK PUSH P,[0] ;AND ALLOW FOR POSSIBLE OVERFLOW SETZM %FLINF ;CLEAR 9'S COUNTER MOVE P3,P2 ;GET # OF DIGITS JUMPLE P2,CHKRND ;NO DIGITS WANTED. FLOU12: EXCH AC0,AC1 ;PUT HI WORD IN AC1 MULI AC1,^D10 ;MUL HI WORD BY 10 PUSH P,AC1 ;STORE DIGIT ON STACK MULI AC0,^D10 ;MUL LOW WORD BY 10 TLO AC0,(1B0) ;STOP OVERFLOW ADD AC0,AC2 ;ADD HI WORD BACK INTO AC0 TLZN AC0,(1B0) ;CARRY AOS (P) ;YES, INCREMENT DIGIT ON STACK MOVE AC2,(P) ;GET THE DIGIT CAIN AC2,^D9 ;IS IT A 9? AOSA %FLINF ;YES. INCR 9'S COUNT SETZM %FLINF ;NO. CLEAR 9'S COUNT SOJG P3,FLOU12 ;FOR G-FORMAT OUTPUT, THERE IS THE POSSIBILITY THAT ROUNDING THE ;NUMBER WILL MAKE IT TOO LARGE TO PRINT IN F-FORMAT, OR THAT NUMBERS ;THAT WE LET THROUGH AT FLOUT7 WILL NOT BE ROUNDED UP, AND WILL BE ;TOO SMALL TO PRINT IN F-FORMAT. THE FOLLOWING CODE CHECKS FOR ;THESE CONDITIONS, AND SETS THE E-FORMAT FLAG IF THE NUMBER IS TOO ;LARGE OR TOO SMALL. IF THERE IS A SCALE FACTOR INVOLVED, IT MODIFIES ;THE NUMBER OF DIGITS ENCODED - NEGATIVE SCALE FACTORS REDUCE THE ;NUMBER OF DIGITS ENCODED, WHILE POSITIVE SCALE FACTORS INCREASE THE ;NUMBER OF DIGITS ENCODED BY 1 DIGIT (OR IF THE SCALE FACTOR ;IS OUTSIDE THE DEFINED RANGE, MODIFIES THE NUMBER OF DIGITS ENCODED ;TO THE SCALE FACTOR). CHKRND: TXNE F,F%GTP ;G-FORMAT? TXNE F,F%ETP+F%DTP ;YES. D OR E? JRST CHKRN2 ;D OR E OR NOT G. LEAVE TLNE AC0,(1B1) ;ROUNDING BIT ON? JRST TEST9 ;YES. TEST # 9'S JUMPL XP,FGFIX ;NO. NG IF EXP STILL LOW JRST FLOU13 ;OTHERWISE OK TEST9: CAMN P2,%FLINF ;IS 9'S COUNT SAME AS DIGITS? JRST TESTXP ;YES. WE GOT OVERFLOW JUMPL XP,FGFIX ;NO. NG IF EXPONENT STILL LOW JRST DORND ;OTHERWISE WE'RE OK TESTXP: CAMGE XP,T3 ;IS UNINCREMENTED EXP TOO BIG? JRST DORND ;NO. WE'RE OK FGFIX: TXO F,F%ETP ;SET TO TYPE "E" JUMPE SF,CHKRN2 ;NO # DIGITS CHANGE IF SF=0 JUMPG SF,FGPOS ;NEED MORE IF SF.GT.0 MOVM AC2,SF ;GET MAGNITUDE OF SCLFCT CAMLE AC2,P2 ;.LE. # OF DIGITS? JRST FLOU13 ;NO. WE'RE ROUNDING ON ZEROES ADD P,SF ;NEED LESS IF SF.LT.0 ADD P2,SF ;ADJUST # DIGITS ADDM SF,%FLINF ;AND 9'S COUNTER SKIPGE %FLINF ;IF 9'S COUNT IS NOW .LT. 0 JRST FLOU13 ;WE HAVE NO ROUNDING JRST DORND ;NOW ROUND WITH FEWER DIGITS FGPOS: MOVEI P3,(SF) ;ENCODE MORE DIGITS SUBI P3,(P2) ;EITHER 1 OR (SF-P2) CAIG SF,1(T3) ;WITHIN DEFINED RANGE? MOVEI P3,1 ;YES. JUST ADD 1 ADDI P2,(P3) ;INCREASE RECORDED # DIGITS JRST FLOU12 ;GO ENCODE CHKRN2: TLNN AC0,(1B1) ;ROUNDING BIT ON? JRST FLOU13 ;NO DORND: XMOVEI AC2,(P) ;GET STACK POINTER MOVE AC1,%FLINF ;GET 9'S COUNT JUMPLE AC1,FLO12B ;INCR LAST DIG IF NO 9'S ZERLP: SETZM (AC2) ;MAKE DIGIT ZERO SUBI AC2,1 ;DECR POINTER SOJG AC1,ZERLP ;DO FOR ALL CONSECUTIVE 9'S FLO12B: AOS (AC2) ;INCR NEXT DIGIT FLOU13: XMOVEI P3,2(P1) ;GET BASE OF STACKED DIGITS SKIPN 1(P1) ;DID OVERFLOW OCCUR? JRST FLOU14 ;NO SUBI P3,1 ;YES - MOVE BACK BASE POINTER ADDI XP,1 ;INCREMENT EXPONENT ADDI P2,1 ;ADD 1 TO # DIGITS FLOU14: JUMPG P2,FLO14A ;ANY DIGITS? TXZ F,NUMSGN ;NO. CLEAR ANY SIGN FLO14A: TXNE F,F%GTP ;YET ANOTHER G-FORMAT TEST TXNE F,F%ETP+F%DTP JRST FLOU15 ;E OR D OR NOT G SETZ SF, ;SCLFCT IS USELESS NOW FOR G-FORMAT FLOU15: SUBI C,2(T3) ;SIGN, POINT AND CHARS. FOLLOWING TXNE F,F%ETP!F%DTP JRST FLOU16 ;HERE FOR F TYPE CONVERSION TXNE F,EQZER ;IS NUMBER ZERO? SETZ SF, ;YES. SET SCALE FACTOR TO 0 ADD SF,XP ;COUNT THE LEADING DIGITS TXNE F,F%GTP JRST [SUBI T3,(XP) ;NO, REDUCE CHAR. AFTER POINT FOR F JRST CHEKDE] ;BUT IGNORE SCALE FACTOR IN WIDTH JUMPLE SF,TRYFIT ;IGNORE NEG SCALING SUBI C,(SF) ;+SCALING JRST TRYFIT ;HERE FOR E AND D TYPE CONVERSION FLOU16: JUMPLE SF,CHEKDE ;IF FACTOR .LE. 0, GO CHECK EXP SUBI C,1 ;EXTRA DIGIT PRINTED SUBI T3,-1(SF) ;REDUCE DIGITS AFTER POINT JUMPGE T3,CHEKDE ;TO COMPENSATE FOR THOSE IN FRONT ADD C,T3 ;HOWEVER IF NOT ENOUGH LEFT ;TAKE FROM IN FRONT CHEKDE: MOVE AC2,%XPVAL ;GET EXPONENT WIDTH JUMPN AC2,GOTEXW ;MIGHT BE DEFAULT MOVEI AC2,2 ;WHICH IS 2 GOTEXW: MOVEM AC2,%FLINF ;SAVE FOR LATER TXNE F,F%DTP+F%ETP ;D OR E FORMAT? CAIL AC2,3 ;YES. ROOM FOR LARGEST EXPONENT? JRST EXPOK ;SURE MOVE AC1,XP ;GET EXPONENT SUB AC1,SF ;REDUCE BY SCALE FACTOR MOVM AC1,AC1 ;GET MAGNITUDE CAMGE AC1,EXPTAB(AC2) ;[3273] WILL EXPONENT FIT? JRST EXPOK ;[3273] YES MOVE AC2,%XPVAL ;[3273] NO. IF EXPONENT WIDTH GIVEN, DIE JUMPN AC2,NOFIT ;[3273] TOO BAD. THE STANDARD REQUIRES STARS TXO F,NOEFLG ;MAYBE JUST BARELY WITH NO "D" OR "E" MOVE AC2,%FLINF ;[3302] GET DEFAULTED VALUE AGAIN CAML AC1,EXPTAB+1(AC2);WILL IT FIT AT ALL? JRST NOFIT ;NO EXPOK: SUB C,%FLINF ;REDUCE SPACE FOR NUMBER SUBI C,2 ;ALLOW FOR E+ OR + AND 1ST DIGIT OF EXP TRYFIT: JUMPG C,FIT1 ;WILL IT FIT? JUMPL C,TRYF0 ;NO. SERIOUS IF .LT. 0 JUMPG SF,GO2ERF ;C=0, OK IF DIGITS BEFORE POINT IFN LZALWAYS,< TXNE F,NUMSGN ;IS SIGN POSITIVE? JRST TRYTZ ;NO. GO TEST IF TRAILING ZEROES SKIPN %SPFLG ;YES. PLUS SIGN REQUIRED? AOJA C,POSIGN ;NO. ELIMINATE IT FOR LEADING ZERO> TRYTZ: JUMPG T3,GO2ERF ;YES. BUT WE'RE OK IF DIGITS AFTER POINT TRYF0: TXNE F,NUMSGN ;IS SIGN POSITIVE JRST NOFIT ;NO. JUMPG T3,TRYF1 ;YES. ANY DIGITS AFTER POINT? JUMPG SF,TRYF1 ;NO. ANY DIGITS BEFORE POINT? JUMPL C,NOFIT ;NO. MUST BE ROOM FOR LEADING 0 TRYF1: CAML C,[-1] ;YES. WOULD THERE BE ROOM WITHOUT SIGN? AOJA C,POSIGN ;YES. PRINT WITHOUT SIGN NOFIT: MOVE AC2,%FWVAL ;GET THE WIDTH JUMPE AC2,FIT ;ALWAYS FITS IF FREE FORMAT SKIPN %FTAST ;ASTERISKS FOR OVERFLOW? JRST FNOAST ;NO. PRINT PART OF NUMBER INSTEAD MOVE P,P1 ;RESTORE STACK POINTER PJRST %FTSUC ;OUTPUT ASTERISKS, CALL USER SUBROUTINE FNOAST: TXNE F,NUMSGN ;NEGATIVE? JRST NOFIT1 ;YES. CAN'T REMOVE SIGN ADDI C,1 ;NO. REMOVE SIGN TXO F,NOSIGN ;AND PRINT NO SIGN LOC NOFIT1: ADD T3,C ;REDUCE # DIGITS AFTER DEC POINT JUMPGE T3,FIT ;IF WE HAVE NEGATIVE TXO F,NOPNT ;OUTPUT NO DECIMAL POINT AOJGE T3,FIT ;IF WE STILL HAVE NEGATIVE ADD SF,T3 ;REDUCE THE DIGITS BEFORE DEC PNT FIT: JUMPLE C,GO2ERF ;NO LEADING BLANKS FIT1: JUMPG SF,FIT2 ;NO 2ND CHECK IF DIGITS BEFORE POINT CAIG C,1 ;MUST LEAVE ROOM FOR LEADING 0 JRST GO2ERF FIT2: PUSHJ P,SPACE ;OUTPUT SPACE SOJA C,FIT ;UNTIL ENOUGH POSIGN: SKIPE %SPFLG ;FORCE PLUS SIGN? JRST NOFIT ;[3273] YES. TOO BAD. STANDARD REQUIRES STARS TXO F,NOSIGN ;[3273] SIGNAL ROOM FOR LEADING ZERO ; AND NO ROOM FOR + SIGN GO2ERF: TXNN F,F%ETP!F%DTP ;TEST FLOATING POINT FLAGS JRST FFORM ;NO, USE FIXED POINT ;FALL INTO EFORM ;E FORMAT EFORM: SUB XP,SF ;SCALE EXPONENT JUMPG P2,EFORMA ;ANY SIGNIFICANT DIGITS? SETZ XP, ;NO. CLEAR THE EXPONENT EFORMA: JUMPLE SF,EFORM1 ;JUMP IF NOT POSITIVE SCALING PUSHJ P,SIGN ;OUTPUT SIGN EFORMB: PUSHJ P,DIGIT ;OUTPUT LEADING DIGITS SOJG SF,EFORMB ;RETURN FOR MORE PUSHJ P,PERIOD ;OUTPUT DOT JUMPLE T3,EFORM4 ;NO MORE IF NO DEC EFORMC: PUSHJ P,DIGIT ;OUTPUT ANOTHER DIGIT SOJG T3,EFORMC ;UNTIL DECS USED UP JRST EFORM4 ;GO OUTPUT EXPONENT EFORM1: PUSHJ P,SIGN ;OUTPUT SIGN IFN LZALWAYS!LZSOME,< JUMPLE C,EFORM2 ;[4201] IF NO ROOM, DON'T OUTPUT LEADING 0 JUMPL SF,EFRM1A ;[4201] IF NEG SCALING, JUST OUTPUT ZERO JUMPG T3,EFRM1A ;[4201] IF THERE ARE NO DIGITS TO OUTPUT PUSHJ P,DIGIT ;[4201] USE THE "OVERFLOW" ZERO ON THE STACK JRST EFORM2 ;[4201] BECAUSE IT MIGHT BE A 1 FROM ROUNDING > IFE LZALWAYS!LZSOME,< JUMPG T3,EFORM2 ;[4201] IF TRAILING DIGITS, DON'T OUTPUT A ZERO JUMPL SF,EFRM1A ;[4201] IF NEG SCALING, JUST OUTPUT ZERO PUSHJ P,DIGIT ;[4201] USE THE "OVERFLOW" ZERO ON THE STACK JRST EFORM2 ;[4201] BECAUSE IT MIGHT BE A 1 FROM ROUNDING > EFRM1A: PUSHJ P,ZERO ;[4201] JUST OUTPUT A ZERO EFORM2: PUSHJ P,PERIOD ;AND DECIMAL POINT JUMPLE T3,EFORM4 ;GO TO EXPONENT IF NO DIGITS JUMPE SF,EFORM3 ;ACCOUNT FOR ZERO SCALING MOVM SF,SF ;GET MAGNITUDE CAIGE SF,(T3) ;SCLFCT .GE. # DECS? JRST EFRM2A ;NO. THINGS ARE OK CAIE SF,(T3) ;EQUAL? MOVEI SF,1(T3) ;GREATER. SET SF=D SUBI SF,1 ;EQUAL. SET SF=D-1 EFRM2A: JUMPE SF,EFORM3 ;[4201] IF SCLFCT NOW ZERO, NO LEADING ZEROES SUBI T3,(SF) ;REDUCE # SIGNIFICANT DIGITS EFRM2B: PUSHJ P,ZERO ;OUTPUT LEADING ZEROES SOJG SF,EFRM2B EFORM3: JUMPLE T3,EFORM4 ;LEAVE IF NO DIGITS AFTER POINT EFRM3A: PUSHJ P,DIGIT ;OUTPUT FRACTIONAL DIGIT SOJG T3,EFRM3A ;RETURN IF MORE DIGITS EFORM4: MOVEI AC1,"E" TXNE F,F%DTP ;USER SPECIFY D-FORMAT? MOVEI AC1,"D" ;YES, GIVE D INSTEAD TXNN F,NOEFLG ;DON'T PRINT IF NO ROOM PUSHJ P,%OBYTE ;OUTPUT "E" OR "D" JUMPGE XP,EFORM5 TXO F,NUMSGN ;TYPE MINUS IF EXPONENT NEGATIVE EFORM5: PUSHJ P,PLUS ;PRINT SIGN MOVE C,%FLINF ;AND SET DIGIT COUNT TXNE F,NOEFLG ;DID WE PRINT "D" OR "E"? ADDI C,1 ;NO. MORE ROOM FOR EXPONENT MOVE P,P1 ;RESTORE STACK POINTER MOVM AC0,XP ;GET EXPONENT JRST OUTP1 ;AND LET OUTP1 DO THE WORK ;F FORMAT FFORM: JUMPLE SF,FFORM3 ;NO LEADING DIGITS PUSHJ P,SIGN ;OUTPUT SIGN FFORMA: PUSHJ P,DIGIT ;OUTPUT INTEGRAL DIGIT SOJG SF,FFORMA ;RETURN IF MORE DIGITS PUSHJ P,PERIOD ;PRINT DECIMAL POINT FFORM1: JUMPLE T3,FFORM2 ;TEST FOR DIG AFTER POINT PUSHJ P,DIGIT ;OUTPUT FRACTIONAL DIGIT SOJG T3,FFORM1 ;RETURN IF MORE DIGITS FFORM2: MOVE P,P1 ;RESTORE STACK TXNN F,F%GTP ;G FORMAT REQUIRES 4 BLANKS POPJ P, ;DONE MOVE C,%XPVAL ;GET EXPONENT WIDTH CAIN C,0 ;IF SET MOVEI C,2 ;IF NOT, DEFAULT IS 4 (2+2) ADDI C,2 ;PLUS 2 FOR E+ OR E- FFRM2A: PUSHJ P,SPACE ;BLANKS SOJG C,FFRM2A POPJ P, ;DONE FFORM3: PUSHJ P,SIGN ;OUTPUT SIGN IFN LZALWAYS!LZSOME,< JUMPLE C,NOLZ ;AND IF WE CAN,> IFE LZALWAYS!LZSOME,< JUMPG T3,NOLZ ;OR IF NO TRAILING DIGITS> PUSHJ P,ZERO ;OUTPUT LEADING "0" NOLZ: PUSHJ P,PERIOD ;OUTPUT DEC. POINT ADD T3,SF ;REDUCE DEC BY SCLFCT JUMPGE T3,FFRM3C ;FINISH IF OK SUB T3,SF ;RESTORE D MOVN SF,T3 ;USE FOR SCLFCT SETZ T3, ;AND NO DIGITS FFRM3C: JUMPGE SF,FFORM1 ;NOW FOR DIGITS PUSHJ P,ZERO ;ZERO AFTER POINT AOJA SF,FFRM3C ;LOOP ON ZEROS ;EXTENDED EXPONENT NUMBERS HAVE 3 MORE BITS OF EXPONENT, ;SO WE MOVE THE MANTISSA OVER TO WHERE IT WOULD BE WERE IT ;A NORMAL FLOATING POINT NUMBER. IF THE EXPONENT IS WITHIN THE NORMAL ;FLOATING POINT RANGE, WE JUST DROP INTO THE STANDARD CODE. IF NOT, ;WE USE A SPARSE POWER OF TEN TABLE TO SCALE THE MANTISSA ;AND LOWER THE MAGNITUDE OF THE BINARY EXPONENT. THE TABLE IS ARRANGED ;SO THAT EACH POWER OF TEN WILL SCALE 2**35 MORE THAN THE NEXT, ;SO WE JUST DIVIDE THE BINARY EXPONENT BY 35 TO GET THE TABLE ENTRY ;TO USE. ;WE LEAVE THE MANTISSA ALIGNED WITH BIT 9 TO AVOID DIVIDE CHECKS. WE ;DON'T LOSE ANY PRECISION THEREBY BECAUSE FOR BOTH MULTIPLICATION ;AND DIVISION WE GET A 4-WORD RESULT. AFTER THE SCALING OPERATION, ;WE HAVE TO ALIGN THE MANTISSA ON BIT 1. THIS TIME, ;HOWEVER, IT MIGHT START ANYWHERE, SO WE CALL %EENRM. EEDEC: LDB P1,[POINT 12,AC0,11];GET THE EXPONENT TLZ AC0,777700 ;AND WIPE IT OUT IN MANTISSA ASHC AC0,3 ;MAKE IT LOOK NORMAL HRREI P1,-2000(P1) ;EXTEND SIGN OF EXPONENT MOVM P2,P1 ;GET MAGNITUDE OF EXP CAMGE P2,%PMEXP ;OUT OF RANGE? POPJ P, ;NO. USE REGULAR CODE SUBI P2,^D70 ;MODIFY FOR SPARSE 10'S TABLE IDIVI P2,^D35 ;DERIVE INDEX FOR EXPONENT IMULI P2,3 ;GET PROPER INDEX JUMPL P1,EENEG ;GO DO MUL IF NEGATIVE PUSHJ P,%EEDIV ;AND DIVIDE IF POSITIVE SUBI P1,(P3) ;REDUCE THE BINARY EXPONENT POPJ P, EENEG: PUSHJ P,%EEMUL ;DO D.P. MULT MOVNI XP,(XP) ;RECORD NEGATIVE DECIMAL EXPONENT ADDI P1,(P3) ;REDUCE MAGNITUDE OF BINARY EXP POPJ P, %EEDIV: SETZB AC2,AC3 ;CLEAR LOWER AC'S SETZB AC4,AC5 ;AND EVEN LOWER AC'S DDIV AC0,%BEXP(P2) ;GET 2-WORD RESULT DDIV AC2,%BEXP(P2) ;GET 4-WORD RESULT JRST EECOM ;JOIN COMMON CODE %EEMUL: DMOVE AC2,%BEXP(P2) ;GET POWER OF TEN ADDI AC3,1 ;BIAS IT - IT IS TRUNCATED DMUL AC0,AC2 ;GET 4-WORD RESULT EECOM: PUSHJ P,%EENRM ;NORMALIZE IT TLO AC0,(1B0) ;PREPARE FOR OVERFLOW TLNE AC2,(1B1) ;ROUNDING BIT ON? DADD AC0,[EXP 0,1] ;YES. ROUND UP TLZ AC1,(1B0) ;TURN OFF LOW SIGN TLZE AC0,(1B0) ;DID WE OVERFLOW? JRST EEOK ;NO TLO AC0,(1B1) ;YES. TURN HIGH BIT ON ADDI P1,1 ;AND INCR THE BINARY EXP EEOK: HLRZ P3,%DEXP(P2) ;GET THE BINARY EXPONENT HRRZ XP,%DEXP(P2) ;GET DECIMAL EXPONENT POPJ P, %EENRM: MOVE T4,AC0 ;GET THE HIGH WORD JFFO T4,EENZ ;LOOK FOR 1ST 1 DMOVE AC0,AC1 ;SHOVE THE NUMBER OVER SUBI P1,^D35 ;AND MODIFY THE EXPONENT MOVE T4,AC0 ;TRY NEXT WORD JFFO T4,EENZ JRST EENEND ;STILL NONE EENZ: SOJE T5,EENEND ;LEAVE STARTING AT BIT 1, DONE IF NO SHIFT SUB P1,T5 ;MODIFY THE BINARY EXPONENT MOVN T4,T5 ;AND GET NEG SHIFT ALSO JUMPL T5,RGTSFT ;DIFFERENT FOR RIGHT SHIFT ASHC AC0,(T5) ;MOVE 1ST AND 2ND WORDS ASH AC1,(T4) ;MOVE BACK 2ND WORD ASHC AC1,(T5) ;MOVE 2ND AND 3RD WORD EENEND: POPJ P, RGTSFT: ASHC AC1,(T5) ;MOVE 2ND AND 3RD ASH AC1,(T4) ;MOVE 2ND BACK ASHC AC0,(T5) ;MOVE 1ST AND 2ND POPJ P, ;SCALE DOUBLE FRACTION BY A POWER OF 10 DPMUL: JUMPE P2,CPOPJ ;IF DEC EXP IS 0, RETURN ADD XP,P2 ;PUT DEC SCALE FACTOR INTO XP MOVN P2,P2 ;TAKE RECIPROCAL OF EXPONENT MOVE P3,%EXP10(P2) ;GET CORRESPONDING BIN EXP ADD P1,P3 ;ADD POWER EXP INTO FRAC EXP MOVE AC2,%HITEN(P2) ;GET DOUBLE SCALING FACTOR MOVE AC3,%LOTEN(P2) ADDI AC3,1 ;BIAS IT - IT IS TRUNCATED DMUL AC0,AC2 ;GET DP PRODUCT TLO AC1,(1B0) ;PREPARE FOR CARRY TLNE AC2,(1B1) ;ROUNDING BIT ON? ADDI AC1,1 ;YES. ADD 1 TO LOW WORD TLZN AC1,(1B0) ;OVERFLOW ADDI AC0,1 ;YES TLNE AC0,(1B1) ;NORMALIZED? POPJ P, ;YES ASHC AC0,1 ;NO, SHIFT LEFT ONE SUBI P1,1 ;AND ADJUST EXPONENT CPOPJ: POPJ P, ;RETURN ; OUTPUT ROUTINES PERIOD: TXNE F,NOPNT ;SUPPRESS DEC PNT? POPJ P, ;YES. JUST LEAVE MOVEI AC1,"." ;DECIMAL POINT PJRST %OBYTE ;PRINT AND RETURN SPACE: SKIPE %FTSLB ;SUPPRESS LEADING BLANKS? POPJ P, ;YES. LEAVE MOVEI AC1," " ;SPACE PJRST %OBYTE ZERO: MOVEI AC1,"0" JRST %OBYTE PLUS: MOVEI AC1,"+" JRST SIGN1 SIGN: TXZE F,NOSIGN ;NO ROOM FOR SIGN? POPJ P, ;JUST RETURN MOVEI AC1," " SKIPE %SPFLG ;FORCE PLUS SIGN? MOVEI AC1,"+" ;YES SIGN1: TXZE F,NUMSGN ;ALWAYS CLEAR FLAG MOVEI AC1,"-" ;SELECT SIGN CAIN AC1," " ;IS IT A SPACE? SKIPN %FTSLB ;YES. SUPPRESS LEADING BLANK? PJRST %OBYTE ;NO. PRINT POPJ P, DIGIT: JUMPLE P2,ZERO ;OUTPUT ZERO IF NO DIGITS SUBI P2,1 ;DECR # DIGITS LEFT MOVE AC1,(P3) ;GET NEXT DIGIT ADDI AC1,"0" ;CONVERT TO ASCII AOJA P3,%OBYTE ;AND PRINT OUTP1: MOVEI XP,1 ;SET UP DIGIT COUNT OUTP2: IDIVI AC0,^D10 ;AND GENERATE DIGITS IN REVERSE PUSH P,AC1 ;AND SAVE THEM ON THE STACK JUMPE AC0,OUTP3 ;ANY LEFT? AOJA XP,OUTP2 ;YES - COUNT AND CARRY ON OUTP3: CAML XP,C ;ANY LEADING SPACES? JRST OUTP4 ;NO PUSHJ P,ZERO ;YES - PRINT ONE SOJA C,OUTP3 ;AND DECREASE UNTIL FINISHED OUTP4: POP P,AC1 ;POP UP DIGIT ADDI AC1,"0" ;ADD ASCII OFFSET PUSHJ P,%OBYTE ;AND PRINT IT SOJN XP,OUTP4 ;REPEAT UNTIL FINISHED POPJ P, ; EXIT FROM ROUTINE FRMTAB: ^D15,,7 ;15.7 DEFAULT ^D25,,^D17 ;25.17 DEFAULT EXPTAB: 1 ;10**0 ^D10 ;10**1 ^D100 ;10**2 ^D1000 ;10**3 PRGEND TITLE LOGIC LOGICAL INPUT/OUTPUT SUBTTL D. TODD/HPW/MD/DCE 28-OCT-81 SEARCH MTHPRM,FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987 ;ALL RIGHTS RESERVED. SEGMENT CODE ENTRY %LINT,%LOUT,%GLINT,%GLOUT EXTERN %IBYTE,%OBYTE,%FWVAL EXTERN %SKIP EXTERN IO.ADR,%FLINF,%SAVE1 EXTERN %ABORT,%FTSLB %GLINT: %LINT: PUSHJ P,%SAVE1 ;SAVE P1 PUSHJ P,LOGSET ;DO SETUP SETZM (P1) ;INPUT SET THE USER'S VARIABLE FALSE MOVEI T3,6 ;SETUP TO SAVE 6 CHARS MOVE T2,[POINT 6,%FLINF];IN SIXBIT JUMPG T4,LINT ;NOT FREE FORMAT SETO T4, ;FREE FORMAT PUSHJ P,%SKIP ;SKIP SPACES POPJ P, ;NULL FIELD JRST LINT0 ;PROCESS FIELD LINT: JUMPE T4,LINT3 ;IF W=0 RETURN PUSHJ P,%IBYTE ;SKIP AN INPUT CHARACTER LINT0: JUMPE T1,LSKIP ;SKIP IF NULL CAIE T1," " ;CHECK FOR A BLANK CAIN T1,11 ;OR LSKIP: SOJA T4,LINT ;YES, IGNORE THE CHARACTER CAIE T1,"." ;PERIOD? JRST NOTDOT ;NO SOJE T4,LINT2 ;ERROR IF JUST DOT PUSHJ P,%IBYTE ;GET NEXT CHAR NOTDOT: PUSHJ P,DEPINF ;DEPOSIT IN INFO WORD CAIE T1,"f" ;LOWER CASE F IS OK CAIN T1,"F" ;CHECK FOR FALSE JRST LINT1 ;YES, PROCESS THE FALSE CHARACTER CAIE T1,"t" ;CHECK FOR TRUE CAIN T1,"T" ;UPPER CASE TOO TRNA ;FOUND A TRUE JRST LINT2 ;NO, ILLEGAL CHARACTER SETOM (P1) ;YES, SET USER'S VARIABLE PRUE LINT1: SOJE T4,LINT3 ;SPACING REQUIRED W=0 PUSHJ P,%IBYTE ;YES, SKIP AN INPUT CHARACTER JUMPG T4,LINT1 ;CONTINUE UNTIL W=0 CAIE T1," " ;SPACE, TAB, OR COMMA ENDS FREE FMT CAIN T1,11 POPJ P, CAIN T1,"," POPJ P, MOVE T0,FLAGS(D) TXNN T0,D%LSD ;LIST-DIRECTED? JRST NOTLSD ;NO CAIN T1,"/" ;SLASH ENDS LDIO POPJ P, NOTLSD: MOVE T0,FLAGS(D) TXNN T0,D%NML ;NAMELIST? JRST NOTNML ;NO CAIE T1,"(" ;YES. EQUAL AND LEFT PAREN CAIN T1,"=" ;ARE DELIMITERS POPJ P, ;SO WE STOP CAIE T1,"$" ;ALSO MIGHT BE NAMELIST DELIM! CAIN T1,"&" POPJ P, ;IN WHICH CASE WE LEAVE NOTNML: PUSHJ P,DEPINF ;ELSE DEPOSIT IN INFO WORD JRST LINT1 ;IGNORE ALL ELSE LINT2: $ACALL ILC ;"ILLEGAL CHARACTER IN DATA" LINT3: POPJ P, ;RETURN %GLOUT: %LOUT: PUSHJ P,%SAVE1 ;SAVE P1 PUSHJ P,LOGSET ;DO SETUP SKIPE %FTSLB ;IF SUPPRESS BLANKS ON JRST LOUT1 ;Don't bother with blank fill SKIPG T4 ;W SPECIFIED? SKIPA T4,[^D15-1] ;NO - SET DEFAULT = 15. SOJE T4,LOUT1 ;CHECK FOR W=1 MOVEI T1," " ;GET A BLANK FOR OUTPUT PUSHJ P,%OBYTE ;OUTPUT A FILL BLANK SOJG T4,.-1 ;CONTINUE FILLING LOUT1: MOVEI T1,"F" ;GET A F FOR FALSE SKIPGE (P1) ;IS VARIABLE FALSE MOVEI T1,"T" ;NO, SET T FOR TRUE PJRST %OBYTE ;OUTPUT THE VALUE AND RETURN TO FOROTS DEPINF: SOJL T3,INFDON ;NO MORE THAN 6 CHARS MOVEI T5,(T1) ;COPY THE CHAR CAIL T5,140 ;CONVERT TO SIXBIT SUBI T5,40 SUBI T5,40 IDPB T5,T2 ;DEPOSIT IN INFO WORD INFDON: POPJ P, LOGSET: SETZM %FLINF ;CLEAR INFO WORD MOVE P1,IO.ADR ;GET ADDR OF VARIABLE MOVE T4,%FWVAL ;GET THE FIELD WIDTH POPJ P, PRGEND TITLE DELIM ROUTINE TO HANDLE DELIMITER OF FREE FORMAT SEARCH MTHPRM,FORPRM ;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED ; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE. ;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1972, 1987 ;ALL RIGHTS RESERVED. SEGMENT CODE ENTRY %SKIP,%FTSUC EXTERN %IBYTE,%OMPAD,%FIXED,%ERTYP,IO.TYP,%FWVAL,%GOPTR ;ROUTINE TO SKIP SPACES OR NULLS ;NON SKIP RETURN IF CHAR IS COMMA OR EOL %SKIP: SKIPGE IRCNT(D) ;ANY CHARS LEFT? POPJ P, ;NO. NON-SKIP RETURN FOR EOL PUSHJ P,%IBYTE ;GET A CHAR JUMPE T1,%SKIP ;SKIP NULLS CAIE T1," " ;BLANK CAIN T1," " ;OR TAB JRST %SKIP ;YES. SKIP IT CAIE T1,"," ;COMMA? AOS (P) ;NO. SKIP RETURN POPJ P, %FTSUC: PUSHJ P,%GOPTR ;GET OUTPUT REC PNTR/COUNT CAMLE T1,%FWVAL ;IF REC COUNT .GE. FIELD WIDTH MOVE T1,%FWVAL ;USE FIELD WIDTH DMOVEM T0,%FIXED ;SAVE FOR USER MOVEI T1,"*" ;FILL WITH ASTERISKS MOVE T3,%FWVAL ;GET OUTPUT WIDTH PUSHJ P,%OMPAD ;OUTPUT STARS MOVE T1,IO.TYP ;GET DATA TYPE MOVEM T1,%ERTYP ;SAVE FOR USER SUBR $ECALL FTS ;ISSUE ERROR MSG, CALL SUBR IF DESIRED POPJ P, END