Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
forcnv.mac
There are 13 other files named forcnv.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV FORCNV CONVERSION ROUTINES ,7(4201)
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1985
;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*<space>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, 1985
;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, 1985
;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, 1985
;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 <TAB>
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, 1985
;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