Trailing-Edge
-
PDP-10 Archives
-
BB-4157E-BM
-
fortran-ots-debugger/forcnv.mac
There are 13 other files named forcnv.mac in the archive. Click here to see a list.
SEARCH FORPRM
TV FORCNV CONVERSION ROUTINES ,6(2033)
;COPYRIGHT (C) 1981 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;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
*************** BEGINNING OF 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
*************** BEGINNING OF 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.
***** End Revision History *****
\
PURGE $SEG$
PRGEND
TITLE ALPHA ALPHANUMERIC INPUT/OUTPUT ROUTINES
SUBTTL D. TODD/DRT/HPW/MD 28-Oct-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
;FROM LIB40 %4(354)
SEGMENT CODE
ENTRY %ALPHI,%ALPHO,%RIGHI,%RIGHO
EXTERN %IBYTE,%OBYTE,W.PNTR
EXTERN IO.ADR,IO.TYP,%SAVE2
EXTERN %SIZTB
DPFLG==20
%ALPHI: PUSHJ P,ALPSET ;DO SETUP
MOVE T2,IO.ADR ;GET THE VARIABLE ADDR
MOVE T0,[ASCII / /];GET A SET OF 5 BLANKS
MOVEM T0,(T2) ;SET THE VARIABLE TO BLANK CLEAR BIT 35
TXNE F,DPFLG ;DOUBLE?
MOVEM T0,1(T2) ;YES. CLEAR THE LOW ORDER WORD
JUMPG T5,AL1 ;IF NO FIELD WIDTH
MOVEI T5,(T4) ;USE THE DEFAULT
AL1: SUBI T4,(T5) ;GET NEG FILL NEEDED
JUMPGE T4,ALPHI1 ;NO FILL IF .GE. 0
ADD T5,T4 ;THERE IS FILL. SET WIDTH TO MAX DEFAULT
ALPHI0: PUSHJ P,%IBYTE ;EXCESS W SKIP INPUT CHARACTERS
AOJL T4,ALPHI0 ;CONTINUE SKIPPING
ALPHI1: PUSHJ P,%IBYTE ;GET AN INPUT BYTE
IDPB T1,IXBP ;PUT IN USER'S VARIBLE
SOJG T5,ALPHI1 ;CONTINUE UNTIL W=0
ALPHI2: POPJ P, ;RETURN TO FOROTS
%ALPHO: PUSHJ P,ALPSET ;DO SOME SETUP
JUMPG T5,AO1 ;WIDTH SPECIFIED
MOVEI T5,(T4) ;NO-SET DEFAULT
AO1: SUBI T4,(T5) ;GET NEG FILL NEEDED
JUMPGE T4,ALPHO1 ;NO FILL IF .GE. 0
ADD T5,T4 ;THERE IS FILL. SET WIDTH TO MAX DEFAULT
MOVEI T1," " ;YES, GET A BLANK
AOSLP: PUSHJ P,%OBYTE ;FILL OUTPUT FILL WITH BLANKS
AOJL T4,AOSLP ;CONTINUE UNTIL MAX W IS REACHED
ALPHO1: ILDB T1,IXBP ;GET THE CHARACTER FROM THE VARIABLE
JUMPN T1,ALPHO2 ;JUMP IF NOT A NULL
MOVEI T1," " ;NULL, GET A BLANK
ALPHO2: PUSHJ P,%OBYTE ;OUTPUT THE CHARACTER
SOJG T5,ALPHO1 ;CONTINUE UNTIL W=0
POPJ P, ;RETURN TO FOROTS
;ROUTINES TO RIGHT JUSTIFY ASCII STRING IN THE USER'S VARIABLE
%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
JUMPN T1,RONN ;IF NULL
MOVEI T1," " ;USE A SPACE CHAR
RONN: PUSHJ P,%OBYTE ;OUTPUT THE CHAR
SOJG T5,ROLP2
POPJ P, ;RETURN TO FOROTS
;Routine to setup for alphabetic conversions
;Sets:
; T3/ index for indexed byte ptr.
; T4/ # fill chars needed
ALPSET: MOVSI T3,(POINT 7,(T3)) ;Create normal indexed byte ptr
MOVEM T3,IXBP
MOVE T3,IO.ADR ;Get byte ptr.
MOVEI T4,5 ;ASSUME SINGLE PRECISION
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
LDB T5,W.PNTR ;GET THE WIDTH FIELD
POPJ P,
SEGMENT DATA
IXBP: 0
PURGE $SEG$
PRGEND
TITLE FLIRT FLOATING POINT INPUT
SUBTTL DAVE NIXON AND TOM EGGERS
SUBTTL D.M.NIXON /DMN/DRT/HPW/MD/CLRH/DCE/CYM 28-Oct-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
SEGMENT DATA
FL.RFR: BLOCK 2 ;RAW FRACTION
FL.RBX: 0 ;RAW BINARY EXPONENT
SEGMENT CODE
ENTRY %FLIRT,%GRIN,%ERIN,%DIRT
ENTRY FL.RFR,FL.RBX
EXTERN %IBYTE,W.PNTR,D.PNTR
EXTERN IO.ADR,IO.TYP,IO.INF,%SAVE4,SCL.SV,ILLEG.
EXTERN %HITEN,%LOTEN,%EXP10,%PTLEN
EXTERN %SKIP,%SIZTB,%HIMAX
IFN FTKL,<EXTERN %EEMUL,%EEDIV,%EENRM>
EXTERN %ABORT
;IF THE FLAG ILLEG. HAS BEEN SET (BY A CALL TO ILL), THE
;INPUT WORD WILL BE SET TO 0 IF ANY ILLEGAL CHARACTERS
;ARE SCANNED FOR THAT WORD.
;THE SYNTAX ANALYSIS FOR THE SINGLE AND DOUBLE PRECISION INPUT
;IS STATE TABLE DRIVEN. EACH NEW INPUT CHARACTER IS CONVERTED TO
;A CHARACTER TYPE AND COMBINED WITH THE OLD "STATE". THIS RESULT
;IS THEN LOOKED UP IN THE TABLE "NXTSTA" TO GET THE NEW STATE AND
;AN INDEX INTO THE "XCTTAB" TABLE TO DISPATCH FOR THE INPUT
;CHARACTER. THE STATE TABLE LOGIC AND THE DISPATCH ROUTINES BUILD
;THREE RESULTS: A DOUBLE PRECISION INTEGER(IN B,C) FOR THE FRACTIONAL
;PART OF THE RESULT, AN INTEGER(IN XP) FOR THE EXPONENT AFTER
;"D" OR "E", AND A COUNTER(IN "X") TO KEEP TRACK OF THE DECIMAL POINT.
;WHEN A TERMINATING CHARACTER IS FOUND, THE DOUBLE PRECISION INTEGER
;IS NORMALIZED TO THE LEFT TO GIVE A DOUBLE PRECISION FRACTION.
;THE DECIMAL POINT POSITION(FROM "X")OR THE IMPLIED DECIMAL POINT
;POSITION FROM THE FORMAT STATEMENT, THE "D" OR "E" EXPONENT, AND ANY
;SCALING FROM THE FORMAT STATEMENT ARE COMBINED INTO A DECIMAL
;EXPONENT. THIS DECIMAL EXPONENT IS USED AS AN INDEX INTO A POWER
;OF TEN TABLE (KEPT IN DOUBLE PRECISION INTEGER PLUS EXPONENT FORM
;SO INTERMEDIATE RESULTS WILL HAVE 8 MORE BITS OF PRECISION THAN
;FINAL RESULTS) TO MULTIPLY THE DOUBLE PRECISION FRACTION. THIS
;RESULT IS THEN ROUNDED TO GIVE A SINGLE PRECISION,
;PDP6/KI10 DOUBLE PRECISION RESULT.
;OVERFLOWS RETURN THE LARGEST POSSIBLE
;NUMBER (WITH CORRECT SIGN), WHILE UNDERFLOWS RETURN 0. NO ERROR
;MESSAGE IS GIVEN FOR EITHER OVER OR UNDERFLOW.
;OLD ACCUMULATOR DEFINITIONS
A==T0
B=A+1 ;RESULT RETURNED IN A OR A AND B
C=B+1 ;B,C, AND D ARE USED AS A MULTIPLE PRECISION
D1=C+1 ; REGISTER FOR DOUBLE PRECISION OPERATIONS
E=D1+1 ;EXTRA AC
XP=T5 ;EXPONENT AFTER D OR E
BXP=P1 ;BINARY EXPONENT
ST==P1 ;STATES
;ST+1 ;TEMPORARY, USES P2 WHICH CAN BE DESTROYED HERE
;P3 ;Used for really temp purposes only
X==P4 ;COUNTS DIGITS AFTER POINT
W==FREEAC ;FIELD WIDTH (** Uses FOROTS's free ac ** )
;RIGHT HALF FLAGS IN AC "F"
DOTFL==1 ;DOT SEEN
MINFR==2 ;NEGATIVE FRACTION
MINEXP==4 ;NEGATIVE EXPONENT
EXPFL==10 ;EXPONENT SEEN IN DATA (MAY BE 0)
DPFLG==20 ;VARIABLE IS DOUBLE PRECISION
EEFLG==40 ;VARIABLE IS EXTENDED EXPONENT
LOCFLG==DOTFL+MINFR+MINEXP+EXPFL+DPFLG+EEFLG
;INPUT CHARACTER TYPES
CRTYP==1 ;CARRIAGE RETURN
DOTTYP==2 ;DECIMAL POINT
DIGTYP==3 ;DIGITS 0-9
SPCTYP==4 ;SPACE OR TAB
EXPTYP==5 ;D OR E
PLSTYP==6 ;PLUS SIGN (+)
MINTYP==7 ;MINUS SIGN (-)
;ANYTHING ELSE IS TYPE 0
%DIRT:
%ERIN:
%GRIN:
%FLIRT: ;INPUT
PUSHJ P,%SAVE4 ;SAVE P1-P4
DSETZM FL.RFR ;CLEAR ALL RAW DATA AND EXPS
SETZM FL.RBX
TXZ F,LOCFLG ;CLEAR LOCAL FLAGS IN F
MOVE T1,IO.TYP ;GET VARIABLE TYPE
CAIN T1,TP%DPX ;EXTENDED EXPONENT?
TXO F,EEFLG ;YES. SET FLAG
MOVE T1,%SIZTB(T1) ;GET ENTRY SIZE
CAIN T1,2 ;IS IT DOUBLE PRECISION?
TXO F,DPFLG ;YES. SET FLAG
SETZM IO.INF ;CLEAR INFORMATION WORD
LDB W,W.PNTR ;GET THE FIELD WIDTH
SETZB C,D1 ;INIT D.P. FRACTION
SETZB ST,XP ;INIT STATE AND DECIMAL EXPONENT
SETZ X, ;INIT "DIGITS AFTER POINT" COUNTER
JUMPG W,GETCH1 ;FIELD SPECIFIED
SETO W, ;SET FREE FORMAT FLAG
PUSHJ P,%SKIP ;FREE FORMAT - SKIP SPACES
JRST ENDF1 ;COMMA OR EOL = NULL FIELD
JRST GETCH2 ;PROCESS FIELD
GETNXT:
GETCHR: JUMPE W,ENDF1 ;END OF FIELD
LSH ST,-^D30 ;MOVE STATE TO BITS 30-32
GETCH1: PUSHJ P,%IBYTE ;GET NEXT CHARACTER
GETCH2: CAIL T1,"0" ;CHECK FOR NUMBER
CAILE T1,"9"
JRST CHRTYP ;NO, TRY OTHER
SUBI T1,"0" ;CONVERT TO NUMBER
GOT1: IORI ST,DIGTYP ;SET TYPE
GOTST: LSHC ST,-2 ;DIVIDE BY NUMBER OF BYTES IN WORD
TLNE ST+1,(1B0) ;TEST WHICH HALF
SKIPA ST,NXTSTA(ST) ;RIGHT HALF (BYTES 2 OR 3)
HLRZ ST,NXTSTA(ST) ;UNFORTUNATELY BYTES 0 OR 1
TLNN ST+1,(1B1) ;WHICH QUADRANT
LSH ST,-9 ;BYTES 0 OR 2
ANDI ST,777 ;LEAVE ONLY RIGHT MOST QUARTER
ROT ST,-3 ;PUT DISPATCH ADDRESS IN BITS 32-35
; AND NEW STATE IN BITS 0-2
LDB P3,[POINT 6,ST,35] ;Just get right-most bits
XCT XCTTAB(P3) ;DISPATCH OR EXECUTE
SOJA W,GETNXT ;RETURN FOR NEXT CHAR.
XCTTAB: JRST ILLCH ; (00) ILLEGAL CHAR
JRST BLNKIN ; (01) CR-LF
IORI F,DOTFL ; (02) PERIOD
JRST DIG ; (03) DIGIT BEFORE POINT
JRST BLNKIN ; (04) BLANK OR TAB
SOJA W,GETNXT ; (05) RETURN FOR NEXT CHAR.
IORI F,MINFR ; (06) NEGATIVE FRACTION
IORI F,MINEXP ; (07) NEGATIVE EXP
SOJA X,DIGAFT ; (10) DIGIT AFTER POINT
JRST DIGEXP ; (11) EXPONENT
JRST DELCK ; (12) DELIMITER TO BACK UP OVER
CHRTYP: CAIN T1,"+" ;CONVERT INPUT CHARS TO CHARACTER TYPE
IORI ST,PLSTYP
CAIN T1,"-"
IORI ST,MINTYP
CAIE T1," " ;SPACE
CAIN T1," " ;TAB
IORI ST,SPCTYP
CAIE T1,"." ;DECIMAL POINT?
JRST NOTDOT ;NO
IORI ST,DOTTYP
HRROS IO.INF ;SIGNAL DECIMAL POINT FOUND
NOTDOT: CAIE T1,"D"
CAIN T1,"E"
JRST GOTEXP
CAIE T1,"d" ;LOWER CASE D?
CAIN T1,"e" ;LOWER CASE E?
JRST GOTEXP ;YES
JRST NOTEXP ;NO
GOTEXP: IORI ST,EXPTYP ;SET STATUS FOR EXPONENT
HRROS IO.INF ;SET INFO FOR EXPONENT FOUND
NOTEXP: MOVE P3,FLAGS(D)
TXNE P3,D%EOR ;End of line set
TRC ST,SPCTYP!CRTYP ;56;SET UP A BLANK
JRST GOTST ;GO DISPATCH ON OLD STATE AND CHAR TYPE
DIGAFT: AOS IO.INF ;INCR # DIGITS AFTER DOT
DIG: JUMPN C,DPDIG ;NEED D.P. YET?
CAMLE D1,MAGIC ;NO, WILL MUL AND ADD CAUSE OVERFLOW?
JRST DPDIG ;MAYBE, SO DO IT IN DOUBLE PRECISION
IMULI D1,12 ;NO, MULTIPLY BY 10 SINGLE PRECISION
ADD D1,T1 ;ADD DIGIT INTO NUMBER
SOJA W,GETNXT ;GO GET NEXT CHARACTER
DPDIG: CAMLE C,MAGIC ;WILL MULTIPLY AND ADD CAUSE OVERFLOW?
AOJA X,DIGRET ;YES
IMULI C,12 ;MULTIPLY HIGH D.P. FRACTION BY 10
MULI D1,12 ;MULTIPLY LOW D.P. FRACTION BY 10
ADD C,D1 ;ADD HI PART OF LO PRODUCT INTO RESULT
MOVE D1,E ;GET LO PART OF LO PRODUCT
TLO D1,(1B0) ;STOP OVERFLOW IF CARRY INTO HI WORD
ADD D1,T1 ;ADD DIGIT INTO FRACTION
TLZN D1,(1B0) ;SKIP IF NO CARRY INTO HI WORD
ADDI C,1 ;PROPOGATE CARRY INTO HI WORD
DIGRET: SOJA W,GETNXT ;DECREMENT FIELD WIDTH AND GET NEXT CHAR
MAGIC: <377777777777-9>/^D10 ;LARGEST NUM PRIOR TO MULTIPLY AND ADD
DIGEXP: HRROS IO.INF ;SET INFO FOR EXPONENT FOUND
IORI F,EXPFL ;SET FLAG TO SAY WE'VE SEEN EXPONENT
IMULI XP,12 ;MULTIPLY BY TEN
ADD XP,T1 ;ADD IN NEXT DIGIT
SOJA W,GETNXT ;DECREMENT FIELD WIDTH AND GET NEXT CHAR
; ? ,CR , . ,0-9, ,D E, + , - ,
NXTSTA: BYTE (9)
000,010,022,031,050,000,051,061,
000,011,022,031,041,053,054,074,
000,012,120,102,042,053,054,074,
000,013,120,114,043,000,054,074,
000,014,120,114,044,000,120,120
;ERROR PROCESSING. IF A REAL ILLEGAL CHARACTER (E.G. ALPHA CHAR) IS
;FOUND DIRECTLY AFTER A NUMBER, IT IS ILLEGAL. IF THE "ILLEGAL FLAG" (ILLEG.)
;IS SET, WE JUST IGNORE THE REST OF THE INPUT AND SET THE RESULT
;TO 0.
ILLCH:
DELCK:: CAME W,[-1] ;FIRST ILLEGAL CHAR IN FREE FORMAT
JUMPL W,ENDF ;NO - DELIMITER OF FREE FORMAT
SKIPE ILLEG. ;ILLEGAL CHAR. FLAG SET?
JRST ERROR1 ;YES. THROW AWAY REST AND RESULT=0
$ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
POPJ P, ;RETURN TO FOROTS
BLNKIN: SETZ T1, ;SET TO NULL CHAR
JUMPL W,ENDF ;FREE FORMAT
MOVE P3,FLAGS(D)
TXNN P3,D%BZ ;BZ FORMAT ON?
SOJA W,GETNXT ;NO. SKIP THE SPACE
LSH ST,-^D30 ;YES. PUT STATE IN BITS 30-32
JRST GOT1 ;AND USE IT
ERROR1: SOJLE W,ZERO ;HAVEN'T DECR WIDTH YET
PUSHJ P,%IBYTE ;THROW AWAY CHAR
JRST ERROR1 ;KEEP GOING UNTIL DONE
ENDF:
ENDF1: DMOVE A,C ;MOVE 2-WORD RESULT TO BOTTOM AC'S
TXNE F,DOTFL ;HAS DECIMAL POINT BEEN INPUT?
JRST ENDF2 ;YES
LDB D1,D.PNTR ;NO, GET DIGITS AFTER POINT FROM FORMAT
SUB X,D1 ; AND MODIFY DECIMAL EXPONENT
ENDF2: HRRE D1,SCL.SV ;GET SCALE FACTOR
TXNN F,EXPFL ;EXPONENT IN DATA?
SUB X,D1 ;NO, ADD INTO EXPONENT
TXNE F,MINEXP ;WAS D OR E EXPONENT NEGATIVE?
MOVNS XP ;YES, SO NEGATE IT
ADD X,XP ;ADD EXPONENT FROM D OR E
NORM: MOVEI BXP,106 ;INIT BINARY EXPON FOR D.P. INTEGER
JUMPN A,NORM1 ;XFER IF AT LEAST ONE 1 IN HIGH HALF
EXCH A,B ;HIGH HALF ZERO, MOVE LOW HALF TO HIGH,
;AND CLEAR LOW HALF
SUBI BXP,^D35 ;AND ADJUST EXPONENT FOR 35 SHIFTS
NORM1: JUMPE A,ZERO ;LEAVE IF BOTH WORDS ZERO
MOVE D1,A ;COPY 1ST WORD
JFFO D1,NORM2 ;JUST IN CASE
JRST ZERO ;EE CLEARS OUT EVERYTHING
NORM2: ASHC A,-1(E) ;NORMALIZE D.P. INTEGER WITH BIN POINT
;BETWEEN BITS 0 AND 1 IN HIGH WORD
SUBI BXP,-1(E) ;AND ADJUST EXPON TO ALLOW FOR SHIFTING
JUMPE X,ENDF6 ;IF DECIMAL EXP=0, NO MUL BY 10 NEEDED
ENDF3: MOVM D1,X ;GET MAG OF DEC EXP
CAILE D1,%HIMAX ;LESS THAN MAX TABLE ENTRY?
JRST BADXP2 ;NO. MUCH TOO BIG!
IFN FTKL,
< PUSHJ P,EETST ;GO TEST FOR BIG SCALING>
MOVM D1,X ;GET MAGNITUDE OF DECIMAL EXPONENT
CAILE D1,%PTLEN ;BETWEEN 0 AND MAX. TABLE ENTRY?
MOVEI D1,%PTLEN ;NO, MAKE IT SO
SKIPGE X ;AND RESTORE CORRECT SIGN
MOVNS D1
SUB X,D1 ;LEAVE ANY EXCESS EXPONENT IN X
DPMUL: MUL B,%HITEN(D1) ;LO FRAC TIMES HI POWER OF TEN(RESULT IN B,C)
MOVE E,B ;GET HI PART OF PREVIOUS PRODUCT OUT OF WAY
MOVE B,A ;COPY HI PART OF FRACTION
MOVE C,%LOTEN(D1) ;GET LOW POWER OF TEN
ADDI C,1 ;BIAS IT - IT IS TRUNCATED
MUL B,C ;HI FRAC TIMES LO POWER OF TEN
TLO E,(1B0)
ADD E,B ;SUM OF HI PARTS OF CROSS PRODUCTS TO AC T
MUL A,%HITEN(D1) ;HI FRACTION TIMES HI POWER OF TEN
TLON E,(1B0) ;DID CARRY OCCUR? ALLOW FOR NEXT CARRY
ADDI A,1 ;CARRY FROM ADDING CROSS PRODUCTS
ADD B,E ;ADD CROSS PRODUCTS TO LO PART
; OF (HI FRAC TIMES HI POW TEN)
TLZN B,(1B0)
AOJA A,ENDF5 ;AND PROPOGATE A CARRY, IF ANY
ENDF5: TLNE A,(1B1) ;NORMALIZED? 1.0 > RESULT >= 0.25
JRST ENDF5A ;YES, RESULT >= 0.5
ASHC A,1 ;NO, SHIFT LEFT ONE PLACE
SUBI BXP,1 ;AND ADJUST EXPONENT
ENDF5A: MOVE D1,%EXP10(D1) ;GET BINARY EXPONENT
ADD BXP,D1 ;ADJUST BINARY EXPONENT
JUMPN X,ENDF3 ;CONTINUE IF ANY MORE DEC EXP LEFT
ENDF6: DMOVEM A,FL.RFR ;SAVE THE RAW LEFT-JUSTIFIED FRACTION
MOVEM BXP,FL.RBX ;AND THE RAW BINARY EXPONENT
TLO A,(1B0) ;START ROUNDING (ALLOW FOR OVERFLOW)
TXNE F,DPFLG ;DOUBLE PRECISION?
JRST DPRND ;TO DPRND
SPRND: ADDI A,200 ;NO, ROUND IN HIGH WORD
TRZ A,377 ;GET RID OF USELESS (UNUSED) BITS
MOVEI B,0 ; DITTO
ENDF7: TLZE A,(1B0) ;CARRY PROPOGATE TO BIT 0?
JRST ENDF7A ;NO
ASHC A,-1 ;YES, RENORMALIZE TO RIGHT
ADDI BXP,1 ;AND ADJUST BINARY EXPONENT
TLO A,(1B1) ;AND TURN ON HI FRACTION BIT
ENDF7A: TXNE F,EEFLG ;EXTENDED EXPONENT?
JRST EERET ;YES. RETURN DIFFERENT FORMAT
CAIGE BXP,200 ;OUT OF RANGE
CAMGE BXP,[-200]
JRST BADEXP ;YES. RETURN ZERO OR INFINITY
ADDI BXP,200 ;ADD IN EXCESS 200
ASHC A,-8 ;NO, LEAVE ROOM FOR EXPONENT
DPB BXP,[POINT 9,A,8] ;INSERT EXPONENT INTO HI WORD
RETURN: TXNE F,MINFR ;RESULT NEGATIVE?
DMOVN A,A ;YES. SO NEGATE RESULT
MOVE T3,IO.ADR ;GET VARIABLE ADDR
MOVEM A,(T3) ;STORE IN USER AREA
TXNE F,DPFLG ;DOUBLE PRECISION?
MOVEM B,1(T3) ;YES, STORE LOW ALSO
POPJ P, ;RETURN TO USER
EERET: CAIGE BXP,2000 ;OUT OF RANGE?
CAMGE BXP,[-2000]
JRST BADEXP ;YES. RETURN ZERO OR INFINITY
ADDI BXP,2000 ;ADD IN EXCESS 2000
ASHC A,-^D11 ;SHIFT TO MAKE ROOM FOR EXP
DPB BXP,[POINT 12,A,11];DEPOSIT THE EXPONENT
JRST RETURN
BADEXP: HRLOI A,377777 ;SET NUMBER TO LARGEST POSSIBLE
HRLOI B,377777 ;FOR PDP-6 OR KI10
JUMPG BXP,RETURN ;DONE IF EXPONENT .GT. ZERO
ZERO: SETZB A,B ;IF NEGATIVE, SET TO ZERO
JRST RETURN
BADXP2: JUMPL X,ZERO ;RETURN ZERO IF DEC EXP NEGATIVE
MOVEI A,3777 ;GET VERY LARGE EXP
MOVEM A,FL.RBX ;SAVE AS RAW BXP
HRLOI A,377777 ;GET LARGEST FRACTION
HRLOI B,377777
DMOVEM A,FL.RFR ;SAVE AS RAW FRACTION
JRST RETURN
IFN FTKL,<
;IF RUNNING ON A KL, WE CAN USE THE SPARSE POWER
;OF TEN TABLE TO SCALE THE NUMBER. IT IS ABSOLUTELY NECESSARY
;FOR EXTENDED EXPONENT NUMBERS
EETST: MOVM P2,X ;GET MAGNITUDE OF DECIMAL EXPONENT
CAIG P2,%PTLEN ;WITHIN NORMAL RANGE?
POPJ P, ;YES. JUST DO IT NORMALLY
ASHC A,-1 ;PREVENT DIVIDE CHECK
ADDI BXP,1 ;AND MODIFY BINARY EXPONENT
ASH P2,1 ;CALCULATE FACTOR OF TEN TO USE
IDIVI P2,^D21 ;IN SPARSE TABLE
SUBI P2,2 ;STARTS WITH 10**21
IMULI P2,3 ;AND EACH ENTRY IS 3 LOCS
JUMPL X,EENEG ;GO DO DIVIDE IF EXP NEGATIVE
PUSHJ P,%EEMUL ;OR MULTIPLY IF POSITIVE
SUBI X,(XP) ;REDUCE THE DECIMAL EXP
ADDI BXP,(P3) ;AND ADD THE BINARY EXP FOUND
POPJ P,
EENEG: PUSHJ P,%EEDIV ;DO D.P. DIVIDE
ADDI X,(XP) ;REDUCE MAGNITUDE OF X
SUBI BXP,(P3) ;MODIFY BINARY EXPONENT
POPJ P, >
;HERE FOR DOUBLE PRECISION ROUNDING
DPRND: TLO B,(1B0) ;START ROUNDING (ALLOW FOR CARRYS)
TXNE F,EEFLG ;EXTENDED EXPONENT?
ADDI B,2000 ;YES. DO SPECIAL ROUNDING
TXNN F,EEFLG ;CHECK AGAIN
ADDI B,200 ;LOW WORD ROUNDING FOR PDP-6 OR KI10
TLZN B,(1B0) ;DID CARRY PROPOGATE TO SIGN?
AOJA A,ENDF7 ;YES, ADD CARRY INTO HIGH WORD
JRST ENDF7 ;AND GO RENORMALIZE IF NECESSARY
PURGE $SEG$
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 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
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
;T3 ; NO. OF DIGITS AFTER DEC. POINT
C==T4 ;CNTR./NO. OF CHARS BEFORE DEC. POINT
XP==T5 ;DECIMAL EXPONENT
SF==P4 ;SCALE FACTOR
DF==FREEAC ;FLOUT smashes FOROTS' free ac.
NUMSGN==1 ;NEGATIVE NUMBER
DIGEXH==2 ;DIGITS EXHAUSTED
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
LOCFLG==NUMSGN+DIGEXH+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==0 ;SWITCH FOR ALWAYS PRINTING LEADING ZEROES
LZSOME==1 ;SWITCH FOR SOMETIMES - ALWAYS EXCEPT WHEN
;POSITIVE NUMBER IS PRINTED WITH ONLY ONE LEADING
;SPACE
ENTRY %FLOUT,%DOUBT,%GROUT,%EOUT
IFN FTKL,<ENTRY %EEMUL,%EEDIV,%EENRM>
EXTERN %OBYTE,%EXP10,%HITEN,%LOTEN,%PTLEN
EXTERN W.PNTR,D.PNTR,X.PNTR
EXTERN IO.ADR,IO.TYP,IO.INF,SCL.SV,%SAVE4
EXTERN %SIZTB,%BEXP,%DEXP
EXTERN %FTSER
;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
MOVE DF,FLAGS(D) ;DDB flags kept in DF throughout FLOUT.
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
TXZ F,NUMSGN!DIGEXH!NOSIGN!EQZER
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:
IFN FTKL,<
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
;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
MOVM P3,P2 ;GET MAGNITUDE OF *10 SCALER
CAIGE P3,%PTLEN ;IS THE POWER OF 10 TABLE LARGE ENOUGH
JRST FLOUT3 ;YES
SKIPL P2 ;NO, SCALE 1ST BY LARGEST ENTRY
SKIPA P2,[%PTLEN] ;GET ADR OF LARGEST POSITIVE POWER OF 10
MOVNI P2,%PTLEN ;GET ADR OF LARGEST NEG POWER OF 10
PUSHJ P,DPMUL ;SCALE BY LARGE POWER OF 10
JRST FLOU2B ;AND GO DO THE SECOND SCALING
IFN FTKL,<
;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
CAIGE P2,200 ;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,
>;END FTKL
;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
IFN FTKL,<
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
>;END FTKL
IFE FTKL,<
MOVE AC3,AC1 ;COPY LOW WORD
MOVE AC4,%LOTEN(P2) ;GET LOW WORD
ADDI AC4,1 ;BIAS IT - IT IS TRUNCATED
MUL AC3,AC4 ;GET LOW PRODUCT
MUL AC1,%HITEN(P2) ;FORM FIRST CROSS PRODUCT
;LOW RESULT IN AC2
MOVE P3,AC0 ;COPY HI FRACTION
MOVE P4,%LOTEN(P2) ;GET LOW WORD
ADDI P4,1 ;BIAS IT - IT IS TRUNCATED
MUL P3,P4 ;FORM 2ND CROSS PRODUCT
;LOW RESULT IN P4
TLO P3,(1B0) ;AVOID OVERFLOW
ADD P3,AC1 ;ADD CROSS PRODUCTS
MUL AC0,%HITEN(P2) ;FORM HI PRODUCT
TLON P3,(1B0) ;DID CROSS PRODUCT OVERFLOW
ADDI AC0,1 ;YES
ADD AC1,P3 ;ADD CROSS PRODUCTS IN
TLON AC1,(1B0) ;OVERFLOW?
ADDI AC0,1 ;YES
SETZ AC4, ;CLEAR A CARRY REGISTER
TLO AC3,(1B0) ;PREVENT OVERFLOW IN LOW RESULT
ADD AC3,AC2 ;ADD 1ST LOW RESULT
TLON AC3,(1B0) ;OVERFLOW?
ADDI AC4,1 ;YES. CARRY ONE
ADD AC3,P4 ;ADD 2ND LOW RESULT
TLNN AC3,(1B0) ;OVERFLOW?
ADDI AC4,1 ;YES. CARRY ONE AGAIN
TLNE AC3,(1B1) ;NOW IS THE HIGH POSITIVE BIT SET?
ADDI AC4,1 ;YES. ROUND UP
ADDI AC1,(AC4) ;ADD IN LOW CARRIES
>;END IFE FTKL
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
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: LDB C,W.PNTR
LDB T3,D.PNTR
HRRE SF,SCL.SV ;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 T3
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
CAML XP,[-1] ;IF EXPONENT .LT. 1
CAMLE XP,T3 ;OR .GT. # DECIMAL PLACES
TXOA F,F%ETP ;SET E CONVERSION
JRST FLOUT8 ;NOT E, JUMP
TXNE DF,D%LSD+D%NML ;NAMELIST OR LIST-DIRECTED?
SUBI T3,1 ;YES, ACCOUNT FOR DIGIT BEFORE DEC PT
;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 IO.INF ;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 IO.INF ;YES. INCR 9'S COUNT
SETZM IO.INF ;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,IO.INF ;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,IO.INF ;AND 9'S COUNTER
SKIPGE IO.INF ;IF 9'S COUNT IS NOW .LT. 0
JRST FLOU13 ;WE HAVE NO ROUNDING
JRST DORND ;NOW ROUND WITH FEWER DIGITS
FGPOS: TXNE DF,D%LSD+D%NML ;NAMELIST OR LIST-DIRECTED?
JRST NOEXDG ;YES. NO EXTRA DIGITS NEEDED
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
NOEXDG: SUBI T3,1 ;REMOVE A DIGIT FOR NMLST/LDIO
CHKRN2: TLNN AC0,(1B1) ;ROUNDING BIT ON?
JRST FLOU13 ;NO
DORND: MOVEI AC2,(P) ;GET STACK POINTER
MOVE AC1,IO.INF ;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: MOVEI 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: LDB AC2,X.PNTR ;GET EXPONENT WIDTH
JUMPN AC2,GOTEXW ;MIGHT BE DEFAULT
MOVEI AC2,2 ;WHICH IS 2
GOTEXW: MOVEM AC2,IO.INF ;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
CAML AC1,EXPTAB(AC2) ;WILL EXPONENT FIT?
TXO F,NOEFLG ;MAYBE JUST BARELY WITH NO "D" OR "E"
CAML AC1,EXPTAB+1(AC2);WILL IT FIT AT ALL?
JRST NOFIT ;NO
EXPOK: SUB C,IO.INF ;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,<
TXNN F,NUMSGN ;IS SIGN POSITIVE?
AOJA C,POSIGN ;YES. ELIMINATE IT FOR LEADING ZERO>
JUMPG T3,GO2ERF ;NO. BUT WE'RE OK IF DIGITS AFTER POINT
TRYF0: TXNE F,NUMSGN ;NO. IS SIGN POSITIVE
JRST TRYF2 ;NO.
JUMPG T3,TRYF1 ;YES. ANY DIGITS AFTER POINT?
JUMPG SF,TRYF1 ;NO. ANY DIGITS BEFORE POINT?
JUMPL C,TRYF2 ;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
TRYF2: TXNN F,F%ETP!F%DTP ;NO. IF E FORMAT WE LOSE
TXZN F,F%GTP ;WAS IT G TO F CONVERSION?
JRST NOFIT ;E TYPE OR NOT G TO F
ADDI C,2 ;REMOVE THE "E+" TRAILING SPACES
ADD C,IO.INF ;ADD THE EXPONENT WIDTH BACK
JRST TRYFIT ;AND TRY AGAIN
NOFIT: LDB AC2,W.PNTR ;GET THE WIDTH
JUMPE AC2,FIT ;ALWAYS FITS IF FREE FORMAT
IFN FTAST,<
MOVE P,P1 ;RESTORE STACK POINTER
MOVEI T1,"*" ;OUTPUT ASTERISKS
PUSHJ P,%OBYTE
SOJG AC2,.-1
PJRST %FTSER ;%Field width too small
>
IFE FTAST,<
ADD SF,C ;LESS DIGITS TO OUTPUT
ADD P2,C ;AND LESS IN STACK
>
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: TXO F,NOSIGN ;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 ;IF ROOM, OUTPUT LEADING 0>
IFE LZALWAYS!LZSOME,<
JUMPG T3,EFORM2 ;OR IF NO TRAILING DIGITS>
PUSHJ P,ZERO ;OUTPUT 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: 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,IO.INF ;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: JUMPE 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
JRST RETRNO ;FINISHED
LDB C,X.PNTR ;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
JRST RETRNO ;FINISHED
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
; OUTPUT ROUTINES
PERIOD: MOVEI AC1,"." ;DECIMAL POINT
PJRST %OBYTE ;PRINT AND RETURN
SPACE: TXNE DF,D%LSD+D%NML ;LIST-DIRECTED OR NMLST?
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," "
TXNE DF,D%SP ;FORCE PLUS SIGN?
MOVEI AC1,"+" ;YES
SIGN1: TXZE F,NUMSGN ;ALWAYS CLEAR FLAG
MOVEI AC1,"-" ;SELECT SIGN
CAIN AC1," " ;IS IT A SPACE?
TXNN DF,D%LSD+D%NML ;YES. LIST-DIRECTED OR NMLST?
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
RETRNO:
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
PURGE $SEG$
PRGEND
TITLE INTEG DECIMAL INTEGER INPUT/OUTPUT
SUBTTL D. TODD/DRT/HPW/MD 28-Oct-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
;FROM LIB40 %4(367)
SEGMENT CODE
ENTRY %INTI,%INTO,%GINTI,%GINTO
EXTERN %IBYTE,%OBYTE,W.PNTR,D.PNTR
EXTERN IO.ADR,%SAVE1
EXTERN %SKIP
EXTERN %FTSER
EXTERN %ABORT
DGSEEN==400000,,0 ;MUST BE 400000, CHECKED WITH JUMPL
SGNFLG==200000,,0 ;MINUS SIGN SEEN
OVRFLG==100000,,0 ;INTEGER OVERFLOW
%GINTI:
%INTI: PUSHJ P,%SAVE1 ;SAVE P1
PUSHJ P,INTSET ;DO SETUP
JUMPG T3,INTI1 ;FIELD WIDTH SPECIFIED
SETO T3, ;SET VARIABLE FIELD FLAG
PUSHJ P,%SKIP ;SKIP SPACES
JRST INTI6 ;COMMA OR EOL (NULL FIELD)
JRST INTI1B ;PROCESS FIELD
INTI1: JUMPE T3,INTI6 ;FIELD EXHAUSTED
PUSHJ P,%IBYTE ;NO, GET NEXT INPUT CHARACTER
INTI1B: CAIG T1,"9" ;CHECK FOR A
CAIGE T1,"0" ;DECIMAL DIGIT (0-9)
JRST INTI3 ;NOT A DECIMAL DIGIT
TXO T2,DGSEEN ;SET DIGIT SEEN FLAG
INTI1A: ANDI T1,17 ;MAKE A BINARY NUMBER
MOVE T4,T5 ;PREPARE FOR 2-WORD MUL
MULI T4,12 ;MULT NUMBER BY A POWER OF 10
TLO T5,400000 ;TURN ON SIGN BIT TO STOP OVERFLOW
ADD T5,T1 ;ACCUMULATE THE SUM
TLZE T5,400000 ;DID WE OVERFLOW?
JUMPE T4,INTI2 ;NO. ANYTHING IN HIGH WORD?
TXO T2,OVRFLG ;YES. WE OVERFLOWED!
INTI2: ADDI T4,1 ;YES. ADD ONE TO OVERFLOW
SOJA T3,INTI1 ;GET NEXT DIGIT
INTI3: CAIN T1,11 ;<TAB>
MOVEI T1," " ;CLEAR THE <TAB> CHARACTER
CAIE T1," " ;CHECK FOR A BLANK
JRST INTI3A ;NOT A BLANK OR <TAB>
JUMPL T3,INTFRE ;YES, CHECK BZ IF NOT FREE FORM
MOVE T0,FLAGS(D)
TXNN T0,D%BZ ;BZ FORMAT ON?
SOJA T3,INTI1 ;NO. SKIP THE CHAR
JRST INTI1A ;YES. TREAT AS A ZERO
INTFRE: JUMPGE T2,INTI1 ;NO DIGITS CONTINUE SCAN IF FREE FORM
INTI3A: JUMPL T2,INTI4 ;DIGIT SEEN YET
CAIN T1,"-" ;NO, IS THIS A MINUS SIGN
TXOA T2,SGNFLG ;YES, SET THE FLAG
CAIN T1,"+" ;CHECK FOR A PLUS
SOJA T3,INTI1 ;YES, GET NEXT CHARACTER
INTI4: CAME T3,[-1] ;IF FIRST CHAR THEN ILLEGAL
JUMPL T3,INTI6 ;NO, CHECK FOR VARIABLE FIELD
$ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
POPJ P, ;RETURN TO FOROTS
INTI6: TXNN T2,OVRFLG ;DID WE OVERFLOW?
JRST INTI6A ;NO
HRLOI T2,377777 ;YES. LOAD BIGGEST VALUE
; IOERR (IOV,64,571,%,Integer overflow,,INTI6A)
$ECALL IOV
INTI6A: TXNE T2,SGNFLG ;CHECK FOR SIGN
MOVN T5,T5 ;NEGATE THE RESULT
MOVEM T5,(P1) ;PUT RESULT IN USER'S VARIABLE
POPJ P, ;RETURN TO FOROTS
%GINTO: MOVEI T1,1 ;AT LEAST ONE DIGIT FOR G-FORMAT
DPB T1,D.PNTR
%INTO: PUSHJ P,%SAVE1 ;SAVE P1
PUSHJ P,INTSET ;DO SETUP
SKIPN T3 ;FREE FORMAT?
MOVEI T3,17 ;YES. TURN INTO FIXED!
LDB T1,D.PNTR ;GET MIN # DIGITS DESIRED
JUMPN T1,GOTMIN ;GOT IT
MOVE T0,FLAGS(D)
TXNE T0,D%LSD+D%NML ;NAMELIST OR LIST-DIRECTED?
MOVEI T1,1 ;YES. PRINT AT LEAST 1 DIGIT
GOTMIN: CAILE T1,(T3) ;BUT DON'T LET MINIMUM NUMBER
MOVEI T1,(T3) ;GET BIGGER THAN FIELD WIDTH
MOVE T4,(P1) ;GET USER'S VARIABLE
JUMPE T4,INTZER ;INTEGER IS 0
INTO1: IDIVI T4,12 ;FORM AN INTEGER
MOVM T5,T5 ;GET REMAINDER MAGNITUDE
IORI T5,"0" ;CONVERT TO ASCII
PUSH P,T5 ;SAVE ON THE STACK
SKIPE T4 ;CHECK FOR END OF DIGITS
AOJA T2,INTO1 ;COUNT THE DIGIT AND CONTINUE
ADDI T2,1 ;COUNT THE LAST DIGIT
INTZER: CAIGE T2,(T1) ;MINIMUM NUMBER PUSHED?
JRST INTO1 ;NO. PUSH MORE
MOVEI T4,(T3) ;COPY FIELD SIZE
SUBI T4,(T2) ;FIND THE EXCESS FIELD SIZE
SKIPL (P1) ;CHECK THE VARIABLE SIGN
JUMPGE T4,INTO2 ;POSITIVE. GO OUTPUT IT
JUMPG T4,INTO2 ;MUST HAVE ROOM FOR SIGN
IFN FTAST,<
HRL T2,T2 ;SETUP STACK RESET
SUB P,T2 ;RESET STACK
MOVEI T1,"*" ;OUTPUT ASTERISKS
PUSHJ P,%OBYTE
SOJG T3,.-1
PJRST %FTSER ;%Field width too small
>
IFE FTAST,<
MOVM T4,T4 ;MAKE POSITIVE
HRLI T4,(T4) ;SET UP EXCESS COUNT
SUB P,T4 ;ADJUST THE STACK
SETZ T4, ;CLEAR THE EXCESS COUNT
>
INTO2: CAIG T4,1 ;ROOM FOR BLANKS?
JRST SGNOUT ;NO
MOVEI T1," " ;YES. OUTPUT SOME
MOVE T0,FLAGS(D)
TXNN T0,D%NML+D%LSD ;BUT NOT IF NMLST OR LDIO
PUSHJ P,%OBYTE
SOJA T4,INTO2
SGNOUT: MOVE T0,FLAGS(D) ;T0= DDB flags
JUMPLE T4,INTO5 ;DELETE SIGN IF NO ROOM
MOVEI T1," " ;ASSUME EXTRA BLANK
JUMPLE T2,NOPLUS ;NO PLUS IF NO DIGITS
TXNE T0,D%SP ;FORCE A PLUS?
MOVEI T1,"+" ;YES. OUTPUT A PLUS SIGN
SKIPGE (P1) ;UNLESS THE VARIABLE IS NEGATIVE
MOVEI T1,"-" ;FOR WHICH USE A MINUS SIGN
CAIN T1," " ;OUTPUTTING A SPACE?
NOPLUS: TXNN T0,D%LSD+D%NML ;YES. DON'T FOR NAMELIST OR LDIO
PUSHJ P,%OBYTE
INTO5: JUMPLE T2,INTO6 ;MIGHT BE NO DIGITS!
POP P,T1 ;GET A CHARACTER FROM THE STACK
PUSHJ P,%OBYTE ;OUTPUT A DIGIT
SOJG T2,INTO5 ;CONTINUE OUTPUTTING THE DIGITS
INTO6: POPJ P, ;RETURN TO FOROTS
INTSET: MOVE P1,IO.ADR ;GET ADDR OF VARIABLE
LDB T3,W.PNTR ;GET THE FIELD WIDTH
SETZB T5,T2 ;CLEAR STORAGE
SETZ T4,
POPJ P,
PURGE $SEG$
PRGEND
TITLE LOGIC LOGICAL INPUT/OUTPUT
SUBTTL D. TODD/HPW/MD/DCE 28-OCT-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
SEGMENT CODE
ENTRY %LINT,%LOUT,%GLINT,%GLOUT
EXTERN %IBYTE,%OBYTE,W.PNTR
EXTERN %SKIP
EXTERN IO.ADR,IO.INF,%SAVE1
EXTERN %ABORT
%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,IO.INF];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: CAIE T1," " ;CHECK FOR A BLANK
CAIN T1,11 ;OR <TAB>
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" ;CKECK, 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: $ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
LINT3: POPJ P, ;RETURN
%GLOUT:
%LOUT: PUSHJ P,%SAVE1 ;SAVE P1
PUSHJ P,LOGSET ;DO SETUP
MOVE T0,FLAGS(D)
TXNE T0,D%NML+D%LSD ;IF NMLST OR LDIO
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 IO.INF ;CLEAR INFO WORD
MOVE P1,IO.ADR ;GET ADDR OF VARIABLE
LDB T4,W.PNTR ;GET THE FILD WIDTH
POPJ P,
PURGE $SEG$
PRGEND
TITLE OCTAL OCTAL INPUT/OUTPUT
SUBTTL D. TODD/DRT/HPW/MD/SWG/DCE 28-OCT-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
SEGMENT CODE
ENTRY %OCTI,%OCTO,%GOCTI,%GOCTO
EXTERN %IBYTE,%OBYTE,W.PNTR,D.PNTR,%SAVE2
EXTERN %SKIP,%SIZTB
EXTERN IO.ADR,IO.TYP
EXTERN %FTSER
EXTERN %ABORT
DGSEEN==400000,,0 ;MUST BE 400000, TEST WITH JUMPL
SGNFLG==200000,,0 ;MINUS SIGN SEEN
%GOCTI:
%OCTI: PUSHJ P,%SAVE2 ;SAVE P1 & P2
PUSHJ P,OCTSET ;DO SETUP
SETZB T4,T5 ;CLEAR THE OUTPUT WORD
JUMPG T3,OCTI1 ;FIELD SPECIFIED
SETO T3, ;NO, SET VARIABLE FLAG
PUSHJ P,%SKIP ;SKIP SPACES
JRST OCTI5 ;NULL FIELD DELIMITED BY COMMA OR EOL
JRST OCTI1B ;PROCESS FIELD
OCTI1: JUMPE T3,OCTI5 ;CHECK FOR END OF FIELD
PUSHJ P,%IBYTE ;GET AN INPUT CHARACTER
OCTI1B: CAIG T1,"7" ;CHECK FOR AN OCTAL
CAIGE T1,"0" ;DIGIT (0-7)
JRST OCTI2 ;56;NO, NOT AN OCTAL DIGIT
TXO T2,DGSEEN ;SET DIGIT SEEN FLAG
OCTI1A: ANDI T1,7 ;MAKE AN OCTAL DIGIT
LSHC T4,3 ;POSITION OUTPUT WORD
TRO T5,(T1) ;OR IN DIGIT
SOJA T3,OCTI1 ;RETURN FOR NEXT CHARACTER
OCTI2: CAIN T1,11 ;<TAB> CHARACTER
MOVEI T1," " ;CLEAR THE <TAB>
CAIE T1," " ;CHECK FOR A BLANK
JRST OCTI2A ;NOT A BLANK OR <TAB>
JUMPL T3,OCTFRE ;FREE FORMAT?
MOVE T0,FLAGS(D)
TXNN T0,D%BZ ;NO. BZ FORMAT ON?
SOJA T3,OCTI1 ;NO. SKIP CHARACTER
JRST OCTI1A ;YES. TREAT AS A ZERO
OCTFRE: JUMPGE T2,OCTI1 ;DIGIT NOT SEEN IN FREE FORM
OCTI2A: JUMPL T2,OCTI3 ;HAS A DIGIT BEEN SEEN
CAIN T1,"-" ;CHECK FOR A MINUS SIGN
TXOA T2,SGNFLG ;SET MINUS FLAG
CAIN T1,"+" ;CHECK FOR A PLUS SIGH
SOJA T3,OCTI1 ;YES, COUNT AND GET NEXT CHAR
OCTI3: CAME T3,[-1] ;FIRST CHAR ILLEGAL
JUMPL T3,OCTI5 ;NO ERROR ON VARIABLE FIELD INPUT
$ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
OCTI5: JUMPN T4,OCTI5A ;LEAVE ALONE IF NON-ZERO 1ST WORD
EXCH T4,T5 ;ELSE SWAP THEM
OCTI5A: TXNN T2,SGNFLG ;CHECK THE SIGN OF THE OUTPUT
JRST OCTI6 ;POSITIVE
DMOVN T4,T4 ;NEGATIVE (NEGATE THE RESULT)
TLO T5,400000 ;DMOVN ZEROES SIGN BIT OF RIGHT
;WORD - VAL IS NEG SO TURN IT ON ALWAYS
OCTI6: MOVEM T4,(P1) ;ASSUME SINGLE PREC
CAIN P2,2 ;[735] IF DOUBLE PRECISION
MOVEM T5,1(P1) ;[735] THEN RETURN BOTH HALVES
POPJ P, ;RETURN TO FOROTS
%GOCTO:
%OCTO: PUSHJ P,%SAVE2 ;SAVE P1 & P2
PUSHJ P,OCTSET ;DO SETUP
MOVSI T5,(POINT 3,(P1)) ;GET AN OCTAL BYTE POINTER
JUMPN T3,OCTO1 ;CHECK FOR VARIABLE FIELD OUTPUT
MOVEI T3,^D15 ;YES SET FILED WIDTH TO O15
CAIN P2,2 ;IF DOUBLE REAL
MOVEI T3,^D25 ;THEN ITS O25
OCTO1: LDB T4,D.PNTR ;GET MINIMUM # DIGITS
JUMPN T4,GOTMIN ;DONE IF NON-ZERO
MOVEI T4,(T3) ;USE WIDTH IF 0
GOTMIN: SUBI T3,(T2) ;FIND THE EXCESS FIELD WIDTH
JUMPLE T3,OCTO2 ;W<= MAX FIELD WIDTH
MOVEI T1," " ;SET UP A BLANK FILLER
PUSHJ P,%OBYTE ;OUTPUT THE FILLER
SOJG T3,.-1 ;CONTINUE UNTIL W=0 (EXCESS)
OCTO2: JUMPE T3,OCTO2B ;GO ON IF FITS
ADD T2,T3 ;MODIFY # CHARS FOR OUTPUT
OCTO2A: ILDB T1,T5 ;GET CHAR
IFN FTAST,<
JUMPN T1,OCTOVR ;OVERFLOW IF DIGIT NON-ZERO
>
AOJL T3,OCTO2A
OCTO2B: ILDB T1,T5 ;GET A CHAR
JUMPN T1,OCTO3A ;GO PRINT ALL IF NON-ZERO
MOVEI T1,"0" ;MAYBE PRINT A ZERO
CAILE T2,(T4) ;PRINT A SPACE IF ALLOWED TO
MOVEI T1," " ;IF W.M WAS SPECIFIED
PUSHJ P,%OBYTE ;OUTPUT ZERO OR SPACE
SOJG T2,OCTO2B
POPJ P, ;LEAVE IF DIGITS EXHAUSTED
OCTO3: ILDB T1,T5 ;GET THE NEXT OCTAL DIGIT
OCTO3A: ADDI T1,"0" ;CONVERT TO ASCII
PUSHJ P,%OBYTE ;OUTPUT A DIGIT
SOJG T2,OCTO3 ;BACK FOR MORE
POPJ P, ;RETURN TO FOROTS
OCTOVR: MOVEI T1,"*" ;OUTPUT ASTERISKS
PUSHJ P,%OBYTE
SOJG T2,.-1
PJRST %FTSER ;%Field width too small
OCTSET: MOVE P1,IO.ADR ;GET ADDR OF VARIABLE
MOVEI T2,^D12 ;12 DIGITS ONLY
MOVE P2,IO.TYP ;GET VARIABLE TYPE
MOVE P2,%SIZTB(P2) ;GET ENTRY SIZE
IMULI T2,(P2) ;GET CORRESPONDING # DIGITS
LDB T3,W.PNTR ;GET THE FIELD WIDTH
POPJ P,
PURGE $SEG$
PRGEND
TITLE HEXIO HEX INPUT/OUTPUT
SUBTTL CHRIS SMITH/CKS 28-Oct-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
;FROM OCTAL I/O
SEGMENT CODE
ENTRY %HEXI,%HEXO
EXTERN %IBYTE,%OBYTE,W.PNTR,D.PNTR,%SAVE2
EXTERN %SKIP,%SIZTB
EXTERN IO.ADR,IO.TYP
EXTERN %FTSER
EXTERN %ABORT
DGSEEN==400000,,0 ;MUST BE 400000, TEST WITH JUMPL
SGNFLG==200000,,0 ;MINUS SIGN SEEN
%HEXI: PUSHJ P,%SAVE2 ;SAVE P1 & P2
PUSHJ P,HEXSET ;DO SETUP
SETZB T4,T5 ;CLEAR THE OUTPUT WORD
JUMPG T3,HEXI1 ;FIELD SPECIFIED
SETO T3, ;NO, SET VARIABLE FLAG
PUSHJ P,%SKIP ;SKIP SPACES
JRST HEXI5 ;NULL FIELD DELIMITED BY COMMA OR EOL
JRST HEXI1B ;PROCESS FIELD
HEXI1: JUMPE T3,HEXI5 ;CHECK FOR END OF FIELD
PUSHJ P,%IBYTE ;GET AN INPUT CHARACTER
HEXI1B: CAILE T1,140 ;LOWER CASE?
SUBI T1,40 ;YES, CONVERT TO UPPER
CAIL T1,"0" ;CHECK FOR A HEX
CAILE T1,"F" ;DIGIT (0-F)
JRST HEXI2 ;NOT A HEX DIGIT
CAILE T1,"9" ;CHECK SOME MORE
CAIL T1,"A"
TXOA T2,DGSEEN ;DIGIT, SET DIGIT SEEN FLAG
JRST HEXI2 ;NONDIGIT, LEAVE
SUBI T1,"0" ;MAKE INTO DIGIT
CAIL T1,"A"-"0"
SUBI T1,"A"-"0"-^D10
HEXI1A: LSHC T4,4 ;POSITION OUTPUT WORD
TRO T5,(T1) ;OR IN DIGIT
SOJA T3,HEXI1 ;RETURN FOR NEXT CHARACTER
HEXI2: CAIN T1,11 ;<TAB> CHARACTER
MOVEI T1," " ;CLEAR THE <TAB>
CAIE T1," " ;CHECK FOR A BLANK
JRST HEXI2A ;NOT A BLANK OR <TAB>
JUMPL T3,HEXFRE ;FREE FORMAT?
MOVE T0,FLAGS(D)
TXNN T0,D%BZ ;NO. BZ FORMAT ON?
SOJA T3,HEXI1 ;NO. SKIP CHARACTER
SETZ T1, ;YES. TREAT AS A ZERO
JRST HEXI1A ;GO INSERT IN OUTPUT NUMBER
HEXFRE: JUMPGE T2,HEXI1 ;DIGIT NOT SEEN IN FREE FORM
HEXI2A: JUMPL T2,HEXI3 ;HAS A DIGIT BEEN SEEN
CAIN T1,"-" ;CHECK FOR A MINUS SIGN
TXOA T2,SGNFLG ;SET MINUS FLAG
CAIN T1,"+" ;CHECK FOR A PLUS SIGH
SOJA T3,HEXI1 ;YES, COUNT AND GET NEXT CHAR
HEXI3: CAME T3,[-1] ;FIRST CHAR ILLEGAL
JUMPL T3,HEXI5 ;NO ERROR ON VARIABLE FIELD INPUT
$ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
HEXI5: JUMPN T4,HEXI5A ;LEAVE ALONE IF NON-ZERO 1ST WORD
EXCH T4,T5 ;ELSE SWAP THEM
HEXI5A: TXNN T2,SGNFLG ;CHECK THE SIGN OF THE OUTPUT
JRST HEXI6 ;POSITIVE
DMOVN T4,T4 ;NEGATIVE (NEGATE THE RESULT)
TLO T5,400000 ;DMOVN ZEROES SIGN BIT OF RIGHT
;WORD - VAL IS NEG SO TURN IT ON ALWAYS
HEXI6: MOVEM T4,(P1) ;ASSUME SINGLE PREC
CAIN P2,2 ;[735] IF DOUBLE PRECISION
MOVEM T5,1(P1) ;[735] THEN RETURN BOTH HALVES
POPJ P, ;RETURN TO FOROTS
%HEXO: PUSHJ P,%SAVE2 ;SAVE P1 & P2
PUSHJ P,HEXSET ;DO SETUP
MOVSI T5,(POINT 4,(P1)) ;GET A HEX BYTE POINTER
JUMPN T3,HEXO1 ;CHECK FOR VARIABLE FIELD OUTPUT
MOVEI T3,^D15 ;YES SET FIELD WIDTH TO O15
CAIN P2,2 ;IF DOUBLE REAL
MOVEI T3,^D25 ;THEN ITS O25
HEXO1: LDB T4,D.PNTR ;GET MINIMUM # DIGITS
JUMPN T4,GOTMIN ;DONE IF NON-ZERO
MOVEI T4,(T3) ;USE WIDTH IF 0
GOTMIN: SUBI T3,(T2) ;FIND THE EXCESS FIELD WIDTH
JUMPLE T3,HEXO2 ;W<= MAX FIELD WIDTH
MOVEI T1," " ;SET UP A BLANK FILLER
PUSHJ P,%OBYTE ;OUTPUT THE FILLER
SOJG T3,.-1 ;CONTINUE UNTIL W=0 (EXCESS)
HEXO2: JUMPE T3,HEXO2B ;GO ON IF FITS
ADD T2,T3 ;MODIFY # CHARS FOR OUTPUT
HEXO2A: ILDB T1,T5 ;GET CHAR
IFN FTAST,<
JUMPN T1,HEXOVR ;OVERFLOW IF DIGIT NON-ZERO
>
AOJL T3,HEXO2A
HEXO2B: ILDB T1,T5 ;GET A CHAR
JUMPN T1,HEXO3A ;GO PRINT ALL IF NON-ZERO
MOVEI T1,"0" ;MAYBE PRINT A ZERO
CAILE T2,(T4) ;PRINT A SPACE IF ALLOWED TO
MOVEI T1," " ;IF W.M WAS SPECIFIED
PUSHJ P,%OBYTE ;OUTPUT ZERO OR SPACE
SOJG T2,HEXO2B
POPJ P, ;LEAVE IF DIGITS EXHAUSTED
HEXO3: ILDB T1,T5 ;GET THE NEXT HEXAL DIGIT
HEXO3A: ADDI T1,"0" ;CONVERT TO ASCII
CAILE T1,"9" ;PAST 9?
ADDI T1,"A"-"0"-^D10 ;YES, CONVERT TO RANGE A-F
PUSHJ P,%OBYTE ;OUTPUT A DIGIT
SOJG T2,HEXO3 ;BACK FOR MORE
POPJ P, ;RETURN TO FOROTS
HEXOVR: MOVEI T1,"*" ;OUTPUT ASTERISKS
PUSHJ P,%OBYTE
SOJG T2,.-1
PJRST %FTSER ;%Field width too small
HEXSET: MOVE P1,IO.ADR ;GET ADDR OF VARIABLE
MOVEI T2,9 ;9 DIGITS ONLY
MOVE P2,IO.TYP ;GET VARIABLE TYPE
MOVE P2,%SIZTB(P2) ;GET ENTRY SIZE
IMULI T2,(P2) ;GET CORRESPONDING # DIGITS
LDB T3,W.PNTR ;GET THE FIELD WIDTH
POPJ P,
PURGE $SEG$
PRGEND
TITLE DELIM ROUTINE TO HANDLE DELIMITER OF FREE FORMAT
; and other random junk
SUBTTL M. DUHAMEL/MD 28-Oct-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
;FROM LIB40 %4(372)
SEGMENT CODE
ENTRY %SKIP,%SIZTB
ENTRY %FTSER ;Give %Field width too small error
EXTERNAL %IBYTE
EXTERN %TRACE,%APRCT,%APRLM,%APRSB
EXTERN U.PDL,%CALU
;ROUTINE TO SAVE EVENTUAL DELIMITER
;CALLED BY PUSHJ
;ROUTINE TO SKIP SPACES
;NON SKIP RETURN IF CHAR IS COMMA OR EOL
%SKIP: PUSHJ P,%IBYTE ;GET A CHAR
CAIE T1," " ;BLANK
CAIN T1," " ;OR TAB
JRST SKIP0 ;YES SKIP
CAIE T1,"," ;COMMA
AOS (P)
POPJ P,
SKIP0: MOVE T0,FLAGS(D)
TXNN T0,D%EOR ;FINI
JRST %SKIP ;CONTINUE
POPJ P, ;OUI-NON SKIP RETURN
%FTSER: AOS T2,%APRCT+.ETOFW ;COUNT ERROR OCCURRENCE
CAMLE T2,%APRLM+.ETOFW ;SKIP IF SHOULD TYPE THE ERROR
JRST CHKU
MOVE T1,U.PDL ;GET USER'S STACK PNTR
MOVE T1,(T1) ;GET RETURN ADDRESS
SUBI T1,1 ;GET CALLING ADDRESS
$ECALL FTS
CHKU: SKIPN T1,%APRSB+.ETOFW ;Any user subroutine?
POPJ P, ;No, return
CHKU1: MOVE T3,U.PDL ;Get original PDL ptr.
MOVE T3,(T3) ;Get PC of the "PUSHJ 17,IOLST."
XMOVEI T3,(T3) ; (Just PC address, pls)
MOVEI T2,.ETOFW ;T2= err number
PJRST %CALU ;Call user subroutine and return
;%SIZTB GIVES THE NUMBER OF WORDS ASSOCIATED WITH EACH TYPE OF
;VARIABLE.
%SIZTB: 1 ;(0) UNDEFINED (INTEGER)
1 ;(1) LOGICAL
1 ;(2) INTEGER
1 ;(3)
1 ;(4) SINGLE REAL
1 ;(5)
1 ;(6) SINGLE OCTAL (INTEGER)
1 ;(7) LABEL
2 ;(10) DOUBLE REAL
2 ;(11) DOUBLE INTEGER
2 ;(12) DOUBLE OCTAL
2 ;(13) EXTENDED DOUBLE REAL
2 ;(14) COMPLEX
1 ;(15) COBOL BYTE STRING
1 ;(16) CHARACTER
1 ;(17) ASCIZ
PURGE $SEG$
PRGEND
TITLE POWTB D.P. INTEGER POWER OF TEN TABLE
SUBTTL D. TODD /DRT/ 28-Oct-81 TOM EGGERS
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
SEGMENT CODE
ENTRY %HITEN, %LOTEN, %EXP10, %PTLEN
ENTRY %DEXP,%HIMAX,%BEXP
;POWER OF TEN TABLE IN DOUBLE PRECISION
;INTEGER FORMAT. EACH ENTRY CONSISTS OF TWO WORDS,
;EACH WITH 35 BITS OF FRACTION (SIGNS ARE EXCLUDED).
;THE BINARY POINT IS BETWEEN BITS 0 AND 1 OF THE
;HI ORDER WORD. THE EXPONENT FOR THE 70 BIT
;FRACTION IS STORED IN THE SHORT TABLE CALLED "EXPTEN".
;FOLLOWING THE STANDARD TABLE IS ATHE EXTENDED EXPONENT
;TABLE, WHICH IS A SPARSE POWER OF TEN TABLE RANGING FROM
;10**21 TO 10**326, FOR USE IN ENCODING AND DECODING G-FLOATING
;NUMBERS.
;THE NUMBERS IN BOTH TABLES ARE TRUNCATED, THAT IS, NO
;ROUNDING HAS BEEN DONE FROM THE (VIRTUAL) THIRD WORD OF
;PRECISION. THUS, ON AVERAGE, THE TABLES ARE BIASED 1/2 BIT
;DOWNWARDS.
DEFINE .TAB. (A)<
NUMBER -246,357347511265,056017357445
NUMBER -242,225520615661,074611525567
NUMBER -237,273044761235,213754053125
NUMBER -234,351656155504,356747065752
NUMBER -230,222114704413,025260341562
NUMBER -225,266540065515,332534432117
NUMBER -222,344270103041,121263540543
NUMBER -216,216563051724,322660234335
NUMBER -213,262317664312,007434303425
NUMBER -210,337003641374,211343364332
NUMBER -204,213302304735,325716130610
NUMBER -201,256162766125,113301556752
NUMBER -176,331617563552,236162112545
NUMBER -172,210071650242,242707256537
NUMBER -167,252110222313,113471132267
NUMBER -164,324532266776,036407360745
NUMBER -160,204730362276,323044526457
NUMBER -155,246116456756,207655654173
NUMBER -152,317542172552,051631227231
NUMBER -146,201635314542,132077636440
NUMBER -143,242204577672,360517606150
NUMBER -140,312645737651,254643547602
NUMBER -135,375417327624,030014501542
NUMBER -131,236351506674,217007711035
NUMBER -126,306044030453,262611673245
NUMBER -123,367455036566,237354252116
NUMBER -117,232574123152,043523552261
NUMBER -114,301333150004,254450504735
NUMBER -111,361622002005,327562626124
NUMBER -105,227073201203,246647575664
NUMBER -102,274712041444,220421535242
NUMBER -077,354074451755,264526064512
NUMBER -073,223445672164,220725640716
NUMBER -070,270357250621,265113211102
NUMBER -065,346453122766,042336053323
NUMBER -061,220072763671,325412633103
NUMBER -056,264111560650,112715401724
NUMBER -053,341134115022,135500702312
NUMBER -047,214571460113,172410431376
NUMBER -044,257727774136,131112537675
NUMBER -041,333715773165,357335267655
NUMBER -035,211340575011,265512262714
NUMBER -032,253630734214,043034737477
NUMBER -027,326577123257,053644127417
NUMBER -023,206157364055,173306466551
NUMBER -020,247613261070,332170204303
NUMBER -015,321556135307,020626245364
NUMBER -011,203044672274,152375747331
NUMBER -006,243656050753,205075341217
NUMBER -003,314631463146,146314631463
A: NUMBER 001,200000000000,000000000000
NUMBER 004,240000000000,000000000000
NUMBER 007,310000000000,000000000000
NUMBER 012,372000000000,000000000000
NUMBER 016,234200000000,000000000000
NUMBER 021,303240000000,000000000000
NUMBER 024,364110000000,000000000000
NUMBER 030,230455000000,000000000000
NUMBER 033,276570200000,000000000000
NUMBER 036,356326240000,000000000000
NUMBER 042,225005744000,000000000000
NUMBER 045,272207335000,000000000000
NUMBER 050,350651224200,000000000000
NUMBER 054,221411634520,000000000000
NUMBER 057,265714203644,000000000000
NUMBER 062,343277244615,000000000000
NUMBER 066,216067446770,040000000000
NUMBER 071,261505360566,050000000000
NUMBER 074,336026654723,262000000000
NUMBER 100,212616214044,117200000000
NUMBER 103,255361657055,143040000000
NUMBER 106,330656232670,273650000000
NUMBER 112,207414740623,165311000000
NUMBER 115,251320130770,122573200000
NUMBER 120,323604157166,147332040000
NUMBER 124,204262505412,000510224000
NUMBER 127,245337226714,200632271000
NUMBER 132,316627074477,241000747200
NUMBER 136,201176345707,304500460420
NUMBER 141,241436037271,265620574524
NUMBER 144,311745447150,043164733651
NUMBER 147,374336761002,054022122623
NUMBER 153,235613266501,133413263574
NUMBER 156,305156144221,262316140533
NUMBER 161,366411575266,037001570661
NUMBER 165,232046056261,323301053417
NUMBER 170,300457471736,110161266322
NUMBER 173,360573410325,332215544007
NUMBER 177,226355145205,250330436404
NUMBER 202,274050376447,022416546105
NUMBER 205,353062476160,327122277527
NUMBER 211,222737506706,206363367626
NUMBER 214,267527430470,050060265574
NUMBER 217,345455336606,062074343133
NUMBER 223,217374313163,337245615771
NUMBER 226,263273376020,327117161367
NUMBER 231,340152275425,014743015665
NUMBER 235,214102366355,050055710521
NUMBER 240,257123064050,162071272645
NUMBER 243,332747701062,216507551417
NUMBER 247,210660730537,231114641751
NUMBER 252,253035116667,177340012343
>
DEFINE NUMBER (A,B,C) <B>
TENTAB: .TAB. %HITEN
DEFINE NUMBER (A,B,C) <C>
.TAB. %LOTEN
%PTLEN==%HITEN-TENTAB ;CALCULATE NUMBER OF TABLE ENTRIES BEFORE "TENS"
DEFINE NUMBER (A,B,C) <A>
.TAB. %EXP10
DEFINE HITABL <
%%EXP==0
HIEXP 21, 0106, 330656232670, 273650000000
HIEXP 31, 0147, 374336761002, 054022122623
HIEXP 42, 0214, 267527430470, 050060265574
HIEXP 52, 0255, 325644342445, 137230015034
HIEXP 63, 0322, 233446460731, 230310256730
HIEXP 73, 0363, 265072116565, 045110433532
HIEXP 84, 0430, 203616042160, 325266273336
HIEXP 94, 0471, 231321375525, 337205744037
HIEXP 105, 0535, 337172572336, 007545174113
HIEXP 115, 0577, 201742476560, 254305755623
HIEXP 126, 0643, 275056630405, 050037577755
HIEXP 136, 0704, 334103204270, 352046213535
HIEXP 147, 0751, 240125245530, 066753037574
HIEXP 158, 1015, 351045347212, 074316542736
HIEXP 168, 1057, 207525153773, 310102120644
HIEXP 179, 1123, 305327273020, 343641442602
HIEXP 189, 1164, 345647674501, 121102720143
HIEXP 200, 1231, 247161432765, 330455055455
HIEXP 210, 1272, 302527746114, 232735577632
HIEXP 221, 1337, 215510706516, 363467704427
HIEXP 231, 1400, 244711331533, 105545654076
HIEXP 242, 1444, 357747123347, 374251221667
HIEXP 252, 1506, 213527073575, 262011603206
HIEXP 263, 1552, 313176275662, 023427342311
HIEXP 273, 1613, 354470426352, 214122564267
HIEXP 284, 1660, 254120203313, 021677205125
HIEXP 295, 1724, 372412614644, 074374052054
HIEXP 305, 1766, 221645055640, 266335117623
HIEXP 316, 2032, 324146136354, 344313410127
HIEXP 326, 2073, 367020634251, 325055547056
>
%HIMAX==^D326
DEFINE HIEXP (DEXP,BEXP,HIWRD,LOWRD) <
XWD BEXP,^D<DEXP>
EXP HIWRD
EXP LOWRD
%%EXP==%%EXP+1
>
%DEXP: HITABL
%BEXP==%DEXP+1
PURGE $SEG$
PRGEND
TITLE NMLST NAMELIST I/O
SUBTTL NAME LIST SEQUENTIAL ACCESS CALLING SEQUENCES - 28-Oct-81
SEARCH 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) 1972,1981 BY DIGITAL EQUIPMENT CORPORATION
COMMENT $
READ (u,name)
READ (u,name,END=c,ERR=d)
MOVEI 16,ARGBLK 0 89 12 14 1718 35
PUSHJ 17,NLI. ------------------------------------
! 3 !TYP!I! X ! u -unit# !
------------------------------------
! 4 !TYP!I! ! END=c !
------------------------------------
! 5 !TYP!I! ! ERR=d !
------------------------------------
! 6 !TYP!I! X ! IOSTAT=i !
------------------------------------
! 10 !TYP!I! X ! NAMELIST addr !
------------------------------------
WRITE (u,name)
WRITE (u,name,END=c,ERR=d)
MOVEI 16,ARGBLK 0 89 12 14 1718 35
PUSHJ 17,NLO. ------------------------------------
! 3 !TYP!I! X ! u -unit# !
------------------------------------
! 4 !TYP!I! ! END=c !
------------------------------------
! 5 !TYP!I! ! ERR=d !
------------------------------------
! 6 !TYP!I! X ! IOSTAT=i !
------------------------------------
! 10 !TYP!I! X ! name list addr !
------------------------------------
The NAMELIST table illustrated below is generated form
the FORTRAN NAMELIST STATEMENT. The first word of the
table is the NAMELIST name in sixbit format. Following
that are a number of two-word entries for scalar
variables, and a number of (N+3)-word entries for array
variables, where N is the dimensionality of the array.
The NAMELIST argument block has the following format.
NAMELIST ADDR/ 0 89 12 14 1718 35
------------------------------------
! SIXBIT /NAMELIST NAME/ !
------------------------------------
! NAME LIST ENTRIES !
------------------------------------
! 0 !
------------------------------------
SCALAR ENTRIES
012 89 12 14 1718 35
------------------------------------
! SIXBIT /SCALAR NAME/ !
------------------------------------
!10! 0 ! T !I! X ! SCALAR ADDR !
------------------------------------
ARRAY ENTRIES
012 89 12 14 1718 35
------------------------------------
! SIXBIT /ARRAY NAME/ !
------------------------------------
!10!#DIM! T !I! X ! BASE ADDR !
------------------------------------
! SIZE ! OFFSET !
------------------------------------
! ! !I! X ! FACTOR 1 !
------------------------------------
! ! !I! X ! FACTOR 2 !
------------------------------------
! ! !I! X ! FACTOR 3 !
------------------------------------
! ! !I! X ! FACTOR N !
------------------------------------
$
SUBTTL JON CAMPBELL /JLC/EDS/AHM
ENTRY %NLI,%NLO,%LDI,%LDO
EXTERNAL %IBYTE,%IBYTC,%OBYTE,%IREC,%ORECS,%%GETIO,%SAVE4,%IBACK
EXTERNAL %RPOS,%SPOS,%GTBLK,%PUSHT,%POPT
EXTERNAL IO.ADR,IO.INC,IO.NUM,IO.TYP,IO.INF,ENC.WD,A.NML,SCL.SV
EXTERNAL FL.RFR,FL.RBX
EXTERNAL %GRIN,%GROUT,%INTI,%INTO,%LINT,%LOUT,%OCTI,%OCTO,%SIZTB
EXTERNAL %IOERR,%POPJ,%POPJ1,%ABORT
SEGMENT DATA
%ALASZ==10 ;SIZE OF ARRAYS FOR STRING INFO
%ALISZ==100 ;INITIAL SIZE FOR STRING CORE ALLOCATION
NLSGN.: 0 ;SIGN OF VALUE
NLFLG.: 0 ;-1=END OF DATA, 0=NULL, 1=NON-NULL
DLFLG.: 0 ;FLAG TO SCAN FOR END DATA DELIM
NLRFR: BLOCK 2 ;RAW FRACTION FROM FLIRT
NLRBX: 0 ;RAW BINARY EXPONENT TO MATCH
NLINFO: 0 ;INFO ABOUT FLIRT NUMBER (REAL PART)
NLVAL.: BLOCK 2 ;VALUE FOUND
NLVL2.: BLOCK 2 ;2ND VALUE FOR COMPLEX
NLRP.: 0 ;REPEAT COUNT
NLDIM.: 0 ;# OF DIMENSIONS
NLVAR.: 0 ;PNTR TO VARIABLE IN ARG LIST
NLNAM.: 0 ;NAME OF NAMELIST/VARIABLE
NLARG.: 0 ;ADDRESS OF ARG LIST
NLCVL.: BLOCK 2 ;CONVERTED VALUE
NLADD.: 0 ;ADDRESS OF USER'S VARIABLE
NLINC.: 0 ;OFFSET BETWEEN USER'S ARRAY ENTRIES
NLSIZ.: 0 ;SIZE OF USER'S ARRAY ENTRIES
CNVTYP: 0 ;CONVERTED VALUE TYPE
VALTYP: 0 ;ORIGINAL VALUE TYPE
VARTYP: 0 ;VARIABLE TYPE
TOTYPE: 0 ;TYPE TO CONVERT TO
OSIZE: 0 ;SIZE OF SUBSEQUENT OUTPUT DATA ELEMENT
NLLCOR: BLOCK %ALASZ ;CORE ALLOCATION PER STRING BUFFER
NLLCNT: BLOCK %ALASZ ;INDIVIDUAL STRING COUNTS
NLLPNT: BLOCK %ALASZ ;INDIVIDUAL STRING POINTERS
NLLTOT: 0 ;TOTAL STRING COUNT (WORDS)
NLTCNT: 0 ;TEMP INDIVIDUAL STRING COUNT
NLTPNT: 0 ;TEMP INDIVIDUAL STRING PNTR
NLTIDX: 0 ;TEMP STRING INDEX
NLTTOT: 0 ;TEMP TOTAL STRING COUNT (WORDS)
NLBUF: BLOCK 200 ;STRING BUFFER
FINFLG: 0 ;FLAGS FOR END OF DATA
LDLFLG: 0 ;FLAGS FOR LEGAL DELIMITERS
NLNUM.: 0 ;# OF USER'S ARRAY ENTRIES TO FILL
NLVFC.: 0 ;FLAGS ALLOWED FOR 1ST CHAR OF VARIABLE
NLFV.: 0 ;VARIABLE ENTRY HAS BEEN FILLED
;CHARACTER FLAGS - SET BY ROUTINE GETCHR
;IN ORDER TO TEST FOR MULTIPLE CHARACTERS (OF A CERTAIN TYPE, FOR INSTANCE),
;EACH CHARACTER HAS BEEN GIVEN AN ASSOCIATED FLAG (PICKED UP IN TABLE
;NLCFLG). ALL SPECIAL CHARACTERS (E.G. "*","$") HAVE THEIR OWN FLAGS, AND
;ALL ALPHABETIC CHARACTERS ARE GIVEN THE FLAG "ALFLAG". THIS TECHNIQUE
;COMPRESSES THE TESTING REQUIRED FOR DELIMITERS, ETC., AND MAKES IT MORE
;GENERAL.
EQUFLG==0
COLFLG==0
SEMFLG==0
LSBFLG==0
RSBFLG==0
RABFLG==0
LABFLG==0
ATFLAG==0
NSFLAG==0
EOLFLG==2
DIGFLG==10
COMFLG==20
SPCFLG==40
ALFLAG==100
LPRFLG==200
RPRFLG==400
PNTFLG==1000
SQFLAG==2000
DQFLAG==4000
SGNFLG==10000
MINFLG==10000
PLSFLG==10000
NLSFLG==20000
NLEFLG==40000
AMPFLG==40000
DOLFLG==40000
NULFLG==100000
SLHFLG==200000
LOGFLG==400000
ASTFLG==1,,0
SEGMENT CODE
;LIST-DIRECTED INPUT & OUTPUT ROUTINES
;USES COMMON SUBROUTINES IN THE NAMELIST CODE TO PICK UP
;VALUES.
%LDI: PUSHJ P,%SAVE4 ;SAVE P1-P4
MOVX T1,SLHFLG ;SLASH OR ERROR ENDS DATA
MOVEM T1,FINFLG
MOVX T1,COMFLG+SPCFLG+SLHFLG+NULFLG+ASTFLG ;LEGAL DELIMITERS
MOVEM T1,LDLFLG ;FOR CHECKING AFTER A SCAN
SETZM NLVFC. ;NO VARIABLES ALLOWED
PUSHJ P,NLINIT ;INIT NMLST PARAMS
MOVX T0,D%LSD ;set for list-directed
IORM T0,FLAGS(D)
LDILP: SETZM IO.ADR ;CLEAR THE I/O ADDR
PUSH P,P1 ;SAVE P1
PUSHJ P,%%GETIO ;GET A VARIABLE
POP P,P1 ;Restore it
SKIPN IO.ADR ;ANY I/O ADDR?
POPJ P, ;NO
PUSHJ P,LDSET ;SETUP VARIABLE PARAMS
PUSHJ P,NLMAIN ;DO MAIN LOOP
SKIPN NLRP. ;IF REPEAT COUNT GONE
TDNN P1,FINFLG ;CHECK IF FINISHED
JRST LDILP ;BACK FOR MORE
LDIFIN:
LDIFLP: SETZM IO.ADR ;CLEAR THE I/O ADDR
PUSHJ P,%%GETIO ;CALL IOLST UNTIL IT
SKIPE IO.ADR ;GIVES NO ADDR
JRST LDIFLP
POPJ P,
;LIST-DIRECTED OUTPUT
;GETS A VARIABLE ADDRESS AND TYPE AND OUTPUTS THE VALUE
;IN THE PROPER FORMAT. IN ORDER TO AVOID A TRAILING COMMA,
;THE COMMA IS OUTPUT FIRST, BUT ONLY AFTER THE 1ST VALUE HAS BEEN
;WRITTEN
;* Warning - smashes Perm acs *
%LDO: PUSHJ P,NLINIT ;INITIALIZE STUFF
MOVX T0,D%LSD ;Set for list-directed
IORM T0,FLAGS(D)
MOVEI T1,1 ;SET OUTPUT FOR 1PG
MOVEM T1,SCL.SV
PUSHJ P,CHKEND ;CHECK FOR COL 1
LDOLP: SETZM IO.ADR ;CLEAR I/O ADDR
PUSHJ P,%%GETIO ;GET A VARIABLE
SKIPN IO.ADR ;ANY I/O ADDR?
POPJ P, ;NO. WE'RE DONE
PUSHJ P,LDSET ;SETUP VARIABLE PARAMS
PUSHJ P,NLMO ;OUTPUT IT
JRST LDOLP ;BACK FOR MORE
LDSET: MOVE T1,IO.ADR ;GET ADDRESS
MOVEM T1,NLADD. ;SAVE IT
HRRZ T1,IO.TYP ;GET VARIABLE TYPE
MOVEM T1,VARTYP ;SAVE IT
MOVE T1,%SIZTB(T1) ;GET SIZE OF ENTRY
MOVEM T1,NLSIZ. ;SAVE IT
MOVE T1,IO.INC ;GET INCR WORD
MOVEM T1,NLINC. ;SAVE OFFSET
MOVE T1,IO.NUM ;GET # LOCS
MOVEM T1,NLNUM. ;SAVE POSITIVE
POPJ P,
;NAMELIST INPUT - AFTER FINDING THE PROPER NAMELIST "BEGIN DATA"
;SEQUENCE ($ OR & IN COLUMN 2), THE NAMELIST NAME IN THE DATA IS
;MATCHED AGAINST THE NAMELIST REQUIRED BY THE USER'S PROGRAM.
;IF IT DOES NOT MATCH, THE INPUT IS SCANNED TO THE NEXT "BEGIN
;DATA" SEQUENCE AND MATCHED AGAIN. UPON A MATCH, WE GRAB A VARIABLE
;NAME FROM THE DATA, AND SEARCH FOR IT IN THE NAMELIST BLOCK TO GET
;THE VARIABLE PARAMETERS. THEN WE LOOK AT WHETHER THE USER HAS
;SPECIFIED ARRAY INDICES IN THE DATA. IF SO, WE CALCULATE
;THE ARRAY REFERENCE. IF THE VARIABLE IS AN ARRAY BUT NO ARRAY INDICES ARE
;GIVEN, THE NUMBER OF ELEMENTS IN THE ARRAY IS USED AS THE POSSIBLE
;NUMBER OF ENTRIES TO FILL, STARTING AT THE FIRST ARRAY ELEMENT.
;NOTE THAT BEFORE THE DATA LOOP WE CLEAR NLNAM., WHICH INDICATES
;TO SUBROUTINE VARNAM TO ACTUALLY GET A NEW VARIABLE NAME FROM THE DATA.
;UNDER CERTAIN CIRCUMSTANCES, WE CAN RETURN FROM NLMAIN WITH THE NEXT
;VARIABLE NAME LEFT IN NLNAM.
%NLI: PUSHJ P,%SAVE4 ;SAVE P1-P4
PUSHJ P,NLINIT ;INIT NMLST PARAMS
MOVE T0,FLAGS(D)
TXZ T0,D%IO ;0=INPUT
TXO T0,D%NML ;MEANS "=" & "(" ARE LOGIC DELIMS
MOVEM T0,FLAGS(D)
MOVX T1,NLEFLG ;END OF DATA FLAGS
MOVEM T1,FINFLG
MOVX T1,COMFLG+SPCFLG+ALFLAG+NLEFLG+NULFLG+ASTFLG ;LEGAL DELIMITERS
MOVEM T1,LDLFLG ;FOR CHECKING AFTER A SCAN
MOVX T1,ALFLAG ;ALPHA CHAR ONLY BEGINS VARIABLE
MOVEM T1,NLVFC. ;SAVE FOR SCAN
MOVE T1,NLARG. ;GET NMLST PNTR
MOVE T1,(T1) ;GET NAMELIST NAME
MOVEM T1,NLVAL. ;SAVE IT
NLILP1: PUSHJ P,NLGETB ;GET BEG OF NAMELIST DATA
PUSHJ P,SKPCHR ;SKIP BEGIN CHAR
PUSHJ P,NLINAM ;GET NAMELIST NAME IN DATA
MOVE T2,NLNAM. ;GET NAME FOUND BY NLINAM
CAME T2,NLVAL. ;IS IT THE ONE WE WANT?
JRST NLILP1 ;NO
SETZM NLNAM. ;CLEAR VARIABLE NAME
NLILP2: PUSHJ P,VARNAM ;GET A VARIABLE NAME
TDNE P1,FINFLG ;END OF DATA?
JRST NLEND ;YES. LEAVE
SKIPN NLNAM. ;FIND ANYTHING?
JRST DOLFND ;NO. IT WAS AN ERROR, UNDOUBTEDLY
TDNE P1,FINFLG ;END OF DATA?
JRST NLEND ;YES. GO FIND END-OF-LINE
PUSHJ P,NLVSRH ;SEARCH IN NAMELIST TABLE
MOVE T1,NLNAM. ;Get name incase error
TXNN P1,NLSFLG ;FOUND?
; IOERR (VNN,799,309,?,Variable $S not in namelist,<T1>,%ABORT)
$ECALL VNN,%ABORT ;?Variable $S is not in namelist
PUSHJ P,CALARR ;YES. CALC ADDR & # ENTRIES
SETZM NLRP. ;CLEAR REPEAT COUNT
SETZM NLNAM. ;CLEAR VARIABLE NAME
SETZM NLFV. ;STARTING NEW VARIABLE
PUSHJ P,NLMAIN ;DO MAIN CODE
TDNN P1,FINFLG ;END OF DATA?
JRST NLILP2 ;NO
JRST NLEND ;YES
DOLFND: PUSHJ P,GTCHRL ;GET NEXT CHAR
TDNN P1,FINFLG ;END OF DATA?
JRST DOLFND ;NO. SCAN SOME MORE
NLEND: PJRST NLEOL ;LOOK FOR END OF LINE AND RETURN TO CALLER
;INITIALIZATION OF NAMELIST/LDIO PARAMETERS
NLINIT: MOVE T1,A.NML ;GET NAMELIST ADDR
MOVEM T1,NLARG. ;SAVE ARG LIST ADDR
SETZM NLLTOT ;CLEAR STRING TOTAL COUNT
SETZ P1, ;CLEAR FLAG WORD
SETZM NLRP. ;CLEAR REPEAT COUNT
SETZM NLFLG. ;CLEAR FLAG
SETZM ENC.WD ;FREE FORMAT
SETZM NLFV. ;SET NO VARIABLES FILLED
SETZM SCL.SV ;CLEAR SCALE FACTOR
POPJ P,
;CALARR - CHECKS THE DIMENSIONALITY OF THE VARIABLE SPECIFIED
;IN THE DATA. IF IT IS AN ARRAY, IT CALLS CALADD, WHICH CHECKS FOR THE
;PRESENCE OF INDICES IN THE DATA. OTHERWISE IT JUST CHECKS FOR
;THE EQUAL-SIGN FOLLOWING THE VARIABLE NAME.
;SMASHES P2, P3, P4.
CALARR: PUSHJ P,VARSET ;SETUP VARIABLE PARAMS
PUSHJ P,NLNB ;SCAN FOR NON-BLANK
SKIPE NLDIM. ;ARRAY?
PUSHJ P,CALADD ;YES. PROCESS INDICES IF ANY
TDNE P1,FINFLG ;LEAVE IF DONE
POPJ P,
CAIE T1,"=" ;DO WE HAVE =?
; IOERR (NEQ,799,513,?,Found "$C" when expecting "=",<T1>,%ABORT)
$ECALL NEQ,%ABORT
PJRST SKPCHR ;SKIP THE EQUAL SIGN
;VARSET - DOES ALL THE NECESSARY SETUP GIVEN THE POINTER
;INTO THE NAMELIST BLOCK FOR THE GIVEN VARIABLE (IN NLVAR.).
VARSET: MOVEI T1,1 ;INITIALIZE # ENTRIES AT 1
MOVEM T1,NLNUM.
MOVE T2,NLVAR. ;GET THE ARG PNTR
MOVE T1,(T2) ;GET VARIABLE NAME
MOVEM T1,NLNAM. ;SAVE IT
XMOVEI T1,@1(T2) ;Get base addr
MOVEM T1,NLADD. ;SAVE IT
LDB T3,[POINT 4,1(T2),12] ;GET TYPE
MOVEM T3,VARTYP ;SAVE TYPE
MOVE T1,%SIZTB(T3) ;GET SIZE
MOVEM T1,NLSIZ. ;SAVE SIZE
MOVEM T1,NLINC. ;AND OFFSET
LDB T1,[POINT 7,1(T2),8] ;GET # DIMS
MOVEM T1,NLDIM. ;SAVE # DIMS
JUMPE T1,NLSCAL ;IT'S A SCALAR
HLRZ T1,2(T2) ;GET # ENTRIES IN ARRAY
MOVEM T1,NLNUM. ;SAVE IT
NLSCAL: POPJ P,
;CALADD - PROCESSES THE INDICES OF AN ARRAY REFERENCE.
;IF THERE ARE NO INDICES, IT GRABS THE ARRAY SIZE DIVIDED
;BY THE ENTRY SIZE TO GET THE # OF ENTRIES. IF THERE ARE INDICES,
;IT ADDS THE OFFSET CALCULATED TO NLADD.
;SMASHES P2,P3,P4
CALADD: MOVE P2,NLVAR. ;GET VARIABLE ENTRY PNTR
CAIE T1,"(" ;LEFT PAREN?
JRST SETARR ;NO. ENTIRE ARRAY
MOVE P3,NLDIM. ;P3= # dims left to process
XMOVEI P4,3(P2) ;P4 points to factors
XMOVEI T1,NLVAL. ;POINT TO VALUE
MOVEM T1,IO.ADR ;FOR %INTI
ADDLP1: PUSHJ P,%INTI ;GET AN INTEGER
MOVE T2,NLVAL. ;GET THE VALUE
IMUL T2,(P4) ;MULTIPLY BY A FACTOR
IMUL T2,NLSIZ. ;GET THE REAL OFFSET
ADDM T2,NLADD. ;ADD TO ADDRESS
PUSHJ P,NLSDEL ;GET THE NEXT DELIMITER
SOJLE P3,ADDLPD ;Go until no more dims
AOJA P4,ADDLP1 ;. .
ADDLPD: PUSHJ P,GETDEL ;GET THE DELIM
CAIE T1,")" ;END OF INDICES?
; IOERR (NRP,799,514,?,Missing right paren,,%ABORT)
$ECALL NRP,%ABORT
PUSHJ P,SKPCHR ;SKIP THE RIGHT PAREN
ALPX: PUSHJ P,NLNB ;AND GO TO NEXT DELIM
;DON'T TOUCH T1 - CONTAINS DELIM
HRRZ T2,2(P2) ;GET THE OFFSET
MOVNI T2,(T2) ;MAKE NEGATIVE
ADDB T2,NLADD. ;ADD INTO ADDR
XMOVEI T3,@1(P2) ;GET ORIG BASE ADDR
SUB T3,T2 ;GET NEG OFFSET TO DESIRED LOC
JUMPLE T3,OFFOK ;OK IF NEG OR ZERO
; IOERR (ILS,799,516,?,Illegal subscript,,%ABORT)
$ECALL ILS,%ABORT ;?Illegal subscript
OFFOK: IDIV T3,NLSIZ. ;GET NEG # ENTRIES IN OFFSET
HLRZ T2,2(P2) ;GET TOTAL # ENTRIES
ADD T2,T3 ;GET # ENTRIES LEFT
MOVEM T2,NLNUM. ;SAVE IT
JUMPG T2,%POPJ ;OK IF .GT. ZERO
$ECALL ILS,%ABORT ;ILLEGAL SUBSCRIPT IF NOT
SETARR: HLRZ T2,2(P2) ;GET # ENTRIES
MOVEM T2,NLNUM. ;SAVE IT
POPJ P,
;VARNAM & NLINAM - ASSEMBLES A VARIABLE NAME OR NAMELIST
;NAME FROM THE DATA. IF A NAME ALREADY EXISTS IN NLNAM., JUST RETURNS
VARNAM: SKIPE NLNAM. ;IF IT WAS NON-ZER
POPJ P, ;IT WAS A BAD LOGIC VALUE
NLINAM: SETZM NLNAM. ;CLEAR NAME
SKIPE DLFLG. ;ARE WE AT END OF PREVIOUS DATA SCAN?
PUSHJ P,NLSDEL ;YES. SCAN FOR THE DELIMITER
PUSHJ P,NLNB ;GET NON-BLANK CHAR
TDNE P1,FINFLG ;END OF DATA?
POPJ P, ;YUP
SKIPE NLFLG. ;ERROR IF NULL ENTRY (COMMA FOUND)
TDNN P1,NLVFC. ;MUST BEGIN WITH ALPHA
; IOERR (ILN,799,515,?,Variable or namelist does not start with letter,,%ABORT)
$ECALL ILN,%ABORT
MOVEI P2,6 ;6 CHARS TOTAL
SKIPA P3,[POINT 6,NLNAM.] ;SIXBIT PNTR, ALREADY GOT 1ST CHAR
NLINL1: PUSHJ P,GTCHRL ;GET NEXT CHAR
TXNN P1,ALFLAG+DIGFLG ;ALPHA OR DIGIT
POPJ P, ;NO. RETURN
CAIL T1,140 ;CONVERT TO SIXBIT
SUBI T1,40
SUBI T1,40
IDPB T1,P3 ;SAVE IT
SOJG P2,NLINL1 ;MAX 6 CHARS
; PJRST NLNA ;THEN SCAN FOR NON-ALPHAMERIC
;SCAN FOR NON-ALPHAMERIC
NLNA: PUSHJ P,GTCHRL ;GET A CHAR
TXNE P1,ALFLAG+DIGFLG ;ALPHA OR DIGIT?
JRST NLNA ;YES. SKIP IT
POPJ P, ;NO. RETURN
;NLVSRH - SEARCH FOR A VARIABLE NAME IN THE NAMELIST
;BLOCK. THE NUMBER OF ENTRIES TAKEN BY A VARIABLE IN THE NAMELIST
;BLOCK IS DEPENDENT ON ITS DIMENSIONALITY.
NLVSRH: TXZ P1,NLSFLG ;CLEAR SEARCH FOUND FLAG
MOVE T3,NLARG. ;GET THE ARG PNTR
ADDI T3,1 ;POINT TO 1ST VARIABLE
NLVLP1: SKIPE T1,(T3) ;GET VARIABLE NAME
CAMN T1,FINCOD ;0 OR END CODE IS END
POPJ P, ;RETURN IF END OF LIST
CAMN T1,NLNAM. ;VARIABLE WE WANT?
JRST NLVFND ;YES!
LDB T2,[POINT 7,1(T3),8] ;NO, GET # DIMS
ADDI T3,2 ;ASSUME SCALAR
JUMPE T2,NLVLP1 ;BACK IF SCALAR
ADDI T3,1(T2) ;MORE JUNK IF ARRAY
JRST NLVLP1
NLVFND: TXO P1,NLSFLG ;SET FOUND FLAG
MOVEM T3,NLVAR. ;SAVE PNTR
POPJ P,
;NLMAIN - THIS IS THE MAIN NAMELIST AND LIST-DIRECTED I/O
;ROUTINE. USING THE VARIABLE PARAMETERS SET UP FOR IT
;(NLADD.,NLSIZ.,NLINC.,NLNUM.) IT SCANS FOR A VALUE AND
;REPEAT COUNT IF THE REPEAT COUNT IS ZERO, DOES THE
;APPROPRIATE VALUE CONVERSION, STORES THE VALUE FOUND
;INTO THE USER'S VARIABLE (OR ARRAY ENTRY), AND DOES ALL
;THE APPROPRIATE INCREMENTING AND DECREMENTING OF THE
;VARIABLE PARAMETERS AND REPEAT COUNT.
NLMAIN:
NLP: SKIPN NLRP. ;REPEAT COUNT?
PUSHJ P,NLSCV ;NO. GET VALUE & REPEAT COUNT
SKIPGE T1,NLFLG. ;DID WE GET A VALUE?
POPJ P, ;NO. LEAVE
JUMPE T1,NULVAL ;JUST DECR REPEAT COUNT IF NULL
MOVE T1,VARTYP ;GET VARIABLE TYPE
CAME T1,CNVTYP ;DID WE CONVERT YET?
PUSHJ P,NLACNV ;NO. CONVERT TO DESIRED FORMAT
DMOVE T1,NLCVL. ;LOAD THE VALUE
MOVE T3,NLSIZ. ;MAKE SURE WE STORE IT RIGHT
XCT NLSTOR(T3)
NULVAL: SETOM NLFV. ;FILLED A VARIABLE
PUSHJ P,NLRPI ;PROCESS VALUE PNTR/COUNTS
MOVE T1,NLINC. ;INCR ARRAY POINTER
ADDM T1,NLADD.
SOSLE NLNUM. ;DECR COUNT
JRST NLP ;LOOP IF MORE
POPJ P,
;NLSTOR - A LITTLE TABLE USED TO STORE THE FINAL VALUES
;INTO THE USER'S VARIABLES. IT IS INDEXED BY THE ENTRY SIZE
;(EITHER 1 OR 2) EXTRACTED FROM %SIZTB. THIS WILL ABSOLUTELY
;NOT WORK FOR A KA-10!!!
NLSTOR: JFCL
MOVEM T1,@NLADD.
DMOVEM T1,@NLADD.
;NLSCV - NAMELIST AND LDIO SCAN FOR A VALUE
;
;THIS ROUTINE SCANS FOR A VALUE AND REPEAT COUNT
;IT BEGINS ITS SCAN IN DOUBLE PRECISION, SO THAT NO
;PRECISION WILL BE LOST IF SOMEWHERE TOWARD THE END OF
;A LIST WE FIND A VARIABLE WHICH IS DOUBLE PRECISION
;WHICH IS STILL COVERED BY A DATA REPEAT COUNT.
;IF "*" FOUND AS DELIMITER, SET THE REPEAT COUNT,
;AND SCAN AGAIN IN DOUBLE PRECISION.
;IF "*" NOT FOUND, SET REPEAT COUNT TO 1 AND RETURN WITH
;VALUE=VALUE FOUND.
NLSCV: SETZM NLRP. ;CLEAR THE REPEAT COUNT
MOVEI T1,TP%DPR ;SCAN FIRST FOR D.P.
MOVEM T1,TOTYPE
MOVEI T1,1 ;SET REPEAT COUNT TO 1
MOVEM T1,NLRP. ;MIGHT FILL NLRP. IN SETNUL
PUSHJ P,NLSCAN ;SCAN FOR VALUE
SKIPG NLFLG. ;LEAVE IF END DATA OR NULL
POPJ P, ;OH, WELL
PUSHJ P,NLSDER ;NO. GET THE DELIMITER
CAIE T1,"*" ;REPEAT COUNT?
POPJ P, ;NO. LEAVE
MOVE T1,VALTYP ;GET THE VALUE TYPE
CAIN T1,TP%DPR ;DOUBLE REAL?
SKIPE IO.INF ;YES. ANY "." OR EXPONENT
JRST RPERR ;NOT REAL OR DOT/EXP FOUND
MOVEI T1,TP%INT ;YES. CONVERT TO INTEGER
MOVEM T1,TOTYPE
PUSHJ P,NLCNV ;DO THE CONVERSION
MOVE T1,NLCVL. ;GET THE CONVERTED VALUE
JUMPL T1,RPERR ;ERROR IF NEGATIVE
MOVMM T1,NLRP. ;SAVE THE REPEAT COUNT
MOVEI T1,TP%DPR ;D.P. AGAIN
MOVEM T1,TOTYPE
PUSHJ P,SKPCHR ;SKIP THE *
SETZM NLFV. ;DON'T SKIP A COMMA
PJRST NLSCAN ;GO GET NEXT VALUE
;THE FOLLOWING CODE SHOULD BE SUBSTITUTED FOR
; PUSHJ P,SKPCHR
; PJRST NLSCAN
;ABOVE, IFTHE ANSI COMMITTEE DECIDES EVENTUALLY THAT 3*<BLANK>4 SHOULD
;BE READ AS 3*,4 (3 NULL VALUES, THEN A 4). AS OF NOW, THE
;COMMITTEE'S PRELIMINARY DECISION HAS BEEN TO ALLOW BOTH
;INTERPRETATIONS. MUCH OF THE INDUSTRY, AS WELL AS
;PDP-11 AND VAX FORTRAN-77, READ THE BLANK AS A VALUE SEPARATOR,
;AND, THEREFORE, AS 3*,4.
REPEAT 0,<
PUSHJ P,GETCHR ;GET THE NEXT CHAR
PUSHJ P,CHKDLM ;CHECK FOR NON-BLANK CHAR
PJRST NLSCAR ;AND GET THE VALUE
>;END REPEAT 0
RPERR: ;IOERR (RPE,799,521,?,Illegal repeat count,,%ABORT)
$ECALL RPE,%ABORT
;NLSCAN - SCAN FOR AN INDIVIDUAL VALUE
;CNVTYP IS SET FOR NO CONVERSION DONE YET, SO THAT THE TEST IN
;NLMAIN WILL FORCE A CONVERSION TO THE APPROPRIATE TYPE.
;THE FIRST CHARACTER OF DATA IS CHECKED FOR ITS VALIDITY
;BY MATCHING ITS ASSOCIATED FLAG (IN P1) AGAINST THE "VALID FIRST CHARACTER
;FLAG LIST" (NLFLST). IF THERE IS NO MATCH, IT IS EITHER A BAD CHARACTER
;IN DATA OR THE BEGINNING OF THE NEXT VARIABLE NAME (NAMELIST ONLY).
;THAT TEST IS DONE BY SETNUL.
NLSCAN: SKIPE DLFLG. ;ARE WE AT END OF PREVIOUS DATA SCAN?
PUSHJ P,NLSDEL ;YES. SCAN FOR THE DELIMITER
PUSHJ P,NLNB ;GET NEXT NON-BLANK CHAR
NLSCAR: SETOM CNVTYP ;SET NO CONVERSION DONE YET
SKIPG NLFLG. ;NON-NULL VALUE FOUND?
POPJ P, ;NO. LEAVE
PUSHJ P,SGNTST ;TEST FOR SIGN
MOVEI T2,NLFLST ;GET FLAG LIST FOR SCAN
PUSHJ P,NLFSRH ;SCAN THE LIST
TXNN P1,NLSFLG ;FOUND?
JRST SETNUL ;NO. TRY FOR NEW VARIABLE
MOVEI P2,(T2) ;COPY INDEX TO TABLES
PUSHJ P,%IBACK ;MOVE PNTR BACK TO 1ST CHAR
DSETZM NLVAL. ;INIT LOW VALUE WORDS
SETOM DLFLG. ;SET FLAG TO SCAN FOR DELIM
XMOVEI T1,NLVAL. ;GET ADDR TO STORE RESULT
MOVEM T1,IO.ADR ;SAVE IT
MOVE T3,TOTYPE ;GET TYPE OF VARIABLE
MOVE T1,NLTYPE(P2) ;GET TYPE
MOVEM T1,VALTYP ;SAVE IT
MOVEM T1,IO.TYP ;SAVE TYPE FOR I/O ROUTINE
MOVE T1,NLSUB(P2) ;GET PROPER SUBR ADDR
PUSHJ P,(T1) ;DO READ
PUSHJ P,GETDEL ;GET THE DELIMITER, SET FLAGS
TDNE P1,LDLFLG ;LEGAL DELIMITER AT END OF SCAN?
POPJ P, ;YES
$ECALL ILC,%ABORT ;NO. ILLEGAL CHAR
;CHECK FOR THE VALIDITY OF THE PRESENCE OF A VARIABLE NAME.
;THIS IS THE ONLY PLACE IN THE CODE WHERE WE HAVE TO CHECK EXPLICITLY
;WHETHER WE ARE DOING NAMELIST OR LIST-DIRECTED I/O. A VARIABLE NAME
;IN THE DATA IS CLEARLY ILLEGAL IN LIST-DIRECTED I/O, AND IS ILLEGAL
;IF IT FOLLOWS DIRECTLY AFTER THE LAST "VARIABLE=" SEQUENCE, THAT IS,
;BEFORE A VARIBLE HAS BEEN FILLED WITH ANY DATA.
;WE USE A SPECIAL LOCATION - NLVFC. (NAMELIST VARIABLE 1ST CHAR)
;WHICH HAS THE FLAGS ALLOWED FOR THE FIRST CHARACTER OF A VARIABLE.
;FOR NAMELIST, THIS IS SET TO "ALFLAG" TO INDICATE THAT VARIABLE
;NAMES MUST START WITH ALPHABETIC CHARACTERS. IT IS SET TO
;ZERO FOR LIST-DIRECTED I/O TO INDICATE THAT VARIABLE NAMES ARE
;NOT ALLOWED FOR LIST-DIRECTED I/O.
;IF EVERYTHING IS LEGAL, THE REST OF THE DATA IS SET TO NULL,
;THAT IS, THE DATA FLAG IS SET TO ZERO (INDICATING A NULL) AND THE
;DATA REPEAT COUNT IS SET TO THE LEFTOVER ARRAY ENTRY COUNT.
SETNUL: TDNE P1,NLVFC. ;THIS CHARACTER ALLOWED?
SETNL1: SKIPN NLFV. ;VARIABLE FILLED YET?
$ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
SETZM NLFLG. ;SET FLAG FOR NULL VALUE
MOVE T1,NLNUM. ;GET # ELEMENTS LEFT
MOVEM T1,NLRP. ;SET FOR REST OF ARRAY
POPJ P,
;SIGN TEST - ACCUMULATES THE SIGN IN FRONT OF A DATA ELEMENT
;AND STUFFS IT AWAY IN NLSGN. ALTHOUGH THE ANSI STANDARD DOESN'T
;ALLOW IT, WE HERE ALLOW MULTIPLE SIGNS (AND DO THE "APPROPRIATE"
;THING, SO THAT --++--- COMES OUT JUST A SINGLE MINUS).
;HOWEVER, IS IS QUITE IMPORTANT THAT A TEST BE PERFORMED AFTER
;A SIGN IS FOUND - THAT A VALID CHARACTER IS FOUND AFTER IT
;FOR THE FIRST CHARACTER OF DATA. SO WE CALL NLFSRH WITH
;THE VALID CHARACTER FLAG LIST, AND GIVE AN ERROR IF THERE IS
;NO CHARACTER FLAG MATCH.
SGNTST: MOVEI T2,1 ;+=1, -=-1
MOVEM T2,NLSGN.
TXNN P1,SGNFLG ;IS THE CHAR A SIGN?
JRST SGNEND ;NO. MOVE BACK PNTR
SGNLP: CAIN T1,"-" ;IS IT A MINUS?
MOVNS NLSGN. ;YES. NEGATE THE SIGN
PUSHJ P,GETCHR ;SKIP THE CHAR
PUSHJ P,NLNBER ;GET THE NEXT NON-BLANK
SKIPG NLFLG. ;NULL VALUE?
; IOERR (SNV,799,522,?,Sign with null value,,%ABORT)
$ECALL SNV,%ABORT
TXNE P1,SGNFLG ;ANOTHER SIGN?
JRST SGNLP ;YES. GO TEST IT
MOVEI T2,NLFLST ;NO. CHECK IN VALID DATA LIST
PUSHJ P,NLFSRH
TXNN P1,NLSFLG ;MATCH?
$ECALL SNV,%ABORT ;Sign with null value
SGNEND: POPJ P,
;NLFSRH - FLAG MATCH SEARCH - THIS SEARCHES A LIST OF
;FLAGS (ADDR SPECIFIED IN T2) FOR A MATCH (LOGICAL
;INTERSECTION) WITH THE FLAGS IN P1, AND PROVIDES THE MATCHING
;INDEX.
NLFSRH: MOVEI T3,(T2) ;SAVE THE LIST PNTR
NLFLP: SKIPN (T2) ;DONE WITH LIST?
JRST NLNFND ;YES. LEAVE
TDNN P1,(T2) ;NO. FLAG MATCH?
AOJA T2,NLFLP ;NO. TRY AGAIN
TXO P1,NLSFLG ;YES. SET FOUND FLAG
NLNFND: SUBI T2,(T3) ;GET RELATIVE INDEX
POPJ P,
;NLCNV - VALUE CONVERSION ROUTINE
;DECIDES WHICH CONVERSION TO DO BY RETRIEVING A CONVERSION
;TABLE ADDR INDEXED BY THE VALUE TYPE, THEN SEARCHES IN THE
;TABLE FOR THE VARIABLE TYPE, AND CALLS THE CORRESPONDING
;CONVERSION ROUTINE.
;NOTE THAT FOR MOST OF THE VALUE/VARIABLE TYPES, WE SIGNAL
;THAT THE CONVERSION HAS BEEN DONE BY PLACING THE CONVERTED TYPE
;IN CNVTYP. FOR ALPHAMERIC CONSTANTS, THIS CANNOT BE DONE, SINCE
;STRING DATA HAS A DIFFERENT SOURCE/REPEAT COUNT MECHANISM THAN
;THE THE OTHER DATA TYPES.
NLACNV: SKIPN T1,VARTYP ;RECORD VARIABLE TYPE
MOVEI T1,TP%INT ;DEFAULT IS INTEGER
MOVEM T1,TOTYPE
NLCNV: MOVE T2,TOTYPE ;GET TYPE DESIRED
CAMN T2,CNVTYP ;SAME AS LAST CONV?
POPJ P, ;YES. FORGET IT
DSETZM NLCVL. ;INIT CONVERTED VALUES
MOVE T3,VALTYP ;GET VALUE TYPE
CAIE T3,TP%LIT ;DON'T SIGNAL CONV IF ALPHA
MOVEM T2,CNVTYP ;BUT DO IF ANYTHING ELSE
MOVE T1,CNVLST(T3) ;GET CONVERSION LIST ADDR/COUNT
JUMPGE T1,BADCNV ;NO CONVERSION!
CNVLP: HLRE T2,(T1) ;GET A "TO" TYPE
JUMPL T2,GOTCNV ;A MATCH IF NEGATIVE
CAME T2,TOTYPE ;DESIRED TYPE?
AOBJN T1,CNVLP ;NO. TRY AGAIN
JUMPGE T1,BADCNV ;A LOSER IF TABLE GONE
GOTCNV: HRRZ T1,(T1) ;GET THE CONV ADDR
PUSHJ P,(T1) ;DO THE CONVERSION
SKIPL NLSGN. ;WAS IT MINUS?
POPJ P, ;NO
DMOVN T1,NLCVL.
DMOVEM T1,NLCVL. ;YES. SAVE IT NEGATIVE
POPJ P,
;NLNB - SCAN FOR NON-BLANK
;SKIPS BLANK-TYPE CHARS, RETURNS ON ANY OTHER CHARACTER
;(EXCEPT SKIPS END-OF-LINE ALTOGETHER)
;RETURNS -1 IF END OF DATA, 0 IF NULL, & 1 IF
;NON-NULL
NLNB: PUSHJ P,GETDEL ;GET CURRENT CHAR
SKIPE NLFV. ;DON'T SKIP FIRST COMMA
TXNN P1,COMFLG ;COMMA TO SKIP?
TXNE P1,EOLFLG ;ARE WE AT EOL?
PUSHJ P,SKPCHR ;YES. SKIP IT
SETZM DLFLG. ;CLEAR SCAN FOR DELIM FLAG
SETOM NLFLG. ;SET FLAG FOR EOF
JRST NLNB1 ;Go to loop, got first character
NLNB0: PUSHJ P,GTCHRL ;Get next char, skip eor
NLNB1: PUSHJ P,BERSCN ;Process character
POPJ P, ;Done, return
JRST NLNB0 ;Loop until done.
;NLNBER - SPECIAL SCAN FOR USE WITH THE REPEAT COUNT.
;THIS SCAN IS LIKE NLNB, BUT IT STOPS
;AT END OF RECORD (THAT IS, IT USES GETCHR INSTEAD OF GTCHRL).
NLNBER: SETZM DLFLG. ;CLEAR THE SCAN FOR DELIM FLAG
SETOM NLFLG. ;SET FLAG FOR EOF
PUSHJ P,GETDEL ;GET LAST DELIM
JRST NLNBR1 ;Already got first char.
NLNBR0: PUSHJ P,GETCHR ;Get character, possibly EOL
NLNBR1: PUSHJ P,BERSCN ;Process character
POPJ P, ;Done, return
JRST NLNBR0 ;Loop
;Return .+1 if done, .+2 if need more characters.
BERSCN: TDNE P1,FINFLG ;EOF OR END OF DATA?
POPJ P, ;YES. LEAVE
TXNN P1,COMFLG+EOLFLG ;COMMA OR EOL?
JRST NOTCEL ;NO
SETZM NLFLG. ;SET FOR COMMA OR EOR
POPJ P,
NOTCEL: TXNE P1,SPCFLG+NULFLG ;SPACE OR TAB OR NULL?
JRST %POPJ1 ;Yes, skip them
MOVEI T2,1 ;NO. SET FLAG FOR DATA
MOVEM T2,NLFLG.
POPJ P,
;NLEOL - SCAN FOR END OF RECORD (OR END OF FILE)
NLEOL: PUSHJ P,GETCHR ;GET A CHAR
TXNN P1,EOLFLG ;GO UNTIL EOL
JRST NLEOL
POPJ P,
;CHKDLM - CHECKS THE DELIMITER WE ARE CURRENTLY LOOKING AT
;AND TREATS IT LIKE WE WERE DOING A FULL SCAN, SETTING NLFLG.
;TO -1 IF END DATA, ZERO IF NULL, SPACE, EOL, OR COMMA, AND
;+1 IF OTHER CHAR
CHKDLM: SETOM NLFLG. ;INIT FOR END OF DATA
TDNE P1,FINFLG ;END OF DATA?
POPJ P, ;YES. LEAVE
SETZM NLFLG. ;NO. PREPARE FOR NULL ITEM
TXNN P1,COMFLG+SPCFLG+NULFLG ;NULL ITEM?
AOS NLFLG. ;NO. SET FOR NON-NULL
POPJ P,
;NLSDEL - SCAN FOR A DELIMITER
;STARTS SCANNING WITH THE CURRENT CHAR (VIA GETDEL).
NLSDEL: PUSHJ P,GETDEL ;GET CURRENT CHAR
TXNE P1,EOLFLG ;ARE WE AT EOL?
PUSHJ P,SKPCHR ;YES. SKIP TO NEXT LINE
SETZM DLFLG. ;CLEAR SCAN FOR DELIM FLAG
JRST NLSDL1 ;Go start loop
NLSDL0: PUSHJ P,GTCHRL ;Get a character
NLSDL1: TDNN P1,FINFLG ;EOF OR END OF DATA?
TXNE P1,COMFLG ;OR COMMA
POPJ P, ;YES. LEAVE
TXNE P1,SPCFLG+NULFLG ;SPACE OR TAB OR NULL?
JRST NLSDL0 ;YES. SKIP IT
POPJ P,
;NLSDER - SCANS FOR A DELIMITER, BUT STOPS AT END OF RECORD
NLSDER: PUSHJ P,GETDEL ;GET THE LAST DELIM
NLSDRL: TDNN P1,FINFLG ;EOF OR END OF DATA?
TXNE P1,EOLFLG ;END OF RECORD?
POPJ P, ;YES. LEAVE
TXNE P1,COMFLG+EOLFLG ;OR, COMMA OR EOL?
JRST DELOFF ;YES. GOT DELIM
TXNN P1,SPCFLG+NULFLG ;SPACE OR TAB OR NULL?
JRST DELOFF ;NO. GOT DELIM
PUSHJ P,GETCHR ;Get character, (could get eol)
JRST NLSDRL ;Loop
DELOFF: SETZM DLFLG. ;CLEAR SCAN FOR DELIM FLAG
POPJ P,
;NLGETB - GET THE BEGINNING OF THE NAMELIST - ALL
;NAMELIST DATA SHOULD BEGIN WITH A "$" OR "&" IN COLUMN 2
;OF THE "CARD" (IBM STRIKES AGAIN!).
NLGETB: PUSHJ P,%RPOS ;GET CURRENT POSITION
CAILE T1,2 ;WILL NEXT CHAR BE COL 2 OR LESS?
JRST GTNREC ;NO. GET NEXT RECORD
MOVEI T1,2 ;GET FROM POSITION 2
PUSHJ P,%SPOS ;SET IT
PUSHJ P,GETCHR ;GET IT
TXNE P1,NLEFLG ;NAMELIST BEG/END FLAG?
POPJ P, ; YUP
GTNREC: PUSHJ P,%IREC ;NO. GO TO NEXT LINE
JRST NLGETB ;NO
;GETDEL - GETS THE CURRENT CHARACTER AND GOES TO SET THE FLAGS
;ASSOCIATED WITH THAT CHARACTER.
;
;GETCHR - GETS THE NEXT CHARACTER AND GOES TO SET FLAGS.
GETDEL: PUSHJ P,%IBYTC ;GET CURRENT CHAR
JRST NLTST ;GO TEST IT
GETCHR:
IFN FTNLC1,<
MOVE T0,FLAGS(D)
TXNN T0,D%NML ;THIS TEST ONLY IF NMLST
JRST GTCLSD ;NOT
PUSHJ P,%RPOS ;GET CHAR POS
CAIGE T1,2 ;SKIP IF .GE. 2
PUSHJ P,%IBYTE ;GET A CHAR
> ;END FTNLC1
GTCLSD: PUSHJ P,%IBYTE ;GET A CHAR
NLTST: SETZ P1, ;CLEAR FLAGS
MOVE T0,FLAGS(D)
TXNE T0,D%EOR ;END OF LINE?
TXO P1,EOLFLG ;YES. SET FLAG
NLNEOF: JUMPE T1,NULFST ;SET NULL FLAG IF NULL
CAIN T1,11 ;TAB CHAR?
TXO P1,SPCFLG ;YES. SET SPACE FLAG
CAIGE T1,40 ;CONTROL CHAR?
POPJ P, ;YES. LEAVE
CAIG T1,100 ;COULD IT BE ALPHA?
JRST NOTALP ;NO
CAIG T1,"z" ;UPPER OR LOWER ALPHA?
CAIGE T1,"a"
CAIG T1,"Z"
CAIGE T1,"A"
POPJ P, ;NO
TXO P1,ALFLAG ;YES. SET FLAG
CAIE T1,"T" ;T OR F SETS LOGFLG
CAIN T1,"t"
TXO P1,LOGFLG
CAIE T1,"F"
CAIN T1,"f"
TXO P1,LOGFLG
POPJ P,
NOTALP: TDOA P1,NLCFLG-40(T1) ;SET CHAR FLAG
NULFST: TXO P1,NULFLG ;SET NULL FLAG
POPJ P,
;GTCHRL - GETS THE NEXT CHARACTER, AUTOMATICALLY GOING ON
;TO THE NEXT RECORD IF END-OF-RECORD IS REACHED.
;
;SKPCHR - IDENTICAL ENTRY TO GTCHRL, USED FOR ITS MNEMONIC VALUE
SKPCHR:
GTCHRL: MOVE T0,FLAGS(D)
TXNN T0,D%EOR ;END OF RECORD ALREADY?
JRST GTCHR1
PUSHJ P,%IREC ;YES. GET NEXT LINE
GTCHR1: PUSHJ P,GETCHR ;GET A CHAR
TESTL: TDNE P1,FINFLG ;END OF DATA?
POPJ P, ;YES. LEAVE
TXNE P1,EOLFLG ;END OF LINE?
JRST NULCHR ;Yes, return a null char
JUMPE T1,GTCHRL ;SKIP IT IF NULL
POPJ P,
NULCHR: SETZ P1, ;CLEAR FLAGS
TXO P1,NULFLG ;CREATE A NULL
SETZ T1, ;RETURN A NULL
POPJ P,
;NLRPI - REPEAT COUNT INCREMENT ROUTINE
;IF THE DATA IS AN ASCII STRING, THERE IS A COUNT AND PNTR ARRAY
;ASSOCIATED WITH THAT STRING.
;IF THERE IS A REPEAT COUNT IN ADDITION, WE ONLY DECREMENT IT
;WHEN THE STRING IS EXHAUSTED, THAT IS, WHEN THE COUNT IS 0.
NLRPI: SKIPN NLLTOT ;DO WE HAVE A STRING COUNT?
JRST DECRP ;NO. JUST DECR REPEAT COUNT
PUSHJ P,NLINAD ;GO INCR STRING PNTR
MOVE T1,NLSIZ. ;ADD THE VARIABLE SIZE
ADDB T1,NLTTOT ;TO THE TEMP COUNT
CAMGE T1,NLLTOT ;STRING EXHAUSTED?
POPJ P, ;NO
SETZM NLTTOT ;CLEAR TEMP COUNT
SETZM NLTIDX ;RESET INDEX
MOVE T1,NLLPNT ;GET PNTR TO 1ST ENTRY
MOVEM T1,NLTPNT ;SAVE IT
MOVE T1,NLLCNT ;SAME WITH COUNT
MOVEM T1,NLTCNT
DECRP: SOSG NLRP. ;DECR REPEAT COUNT
SETZM NLLTOT ;CLEAR STRING COUNT IF 0
POPJ P,
NLINAD: MOVE T1,NLSIZ. ;GET SIZE OF VARIABLE
NLINLP: CAMG T1,NLTCNT ;.GT. CURRENT WORD COUNT?
JRST NLINOK ;NO
SUB T1,NLTCNT ;GET # WORDS LEFT
AOS T3,NLTIDX ;INCR INDEX TO PNTRS
SKIPN T2,NLLPNT(T3) ;ANY MORE STRING
POPJ P, ;NO
MOVEM T2,NLTPNT ;UPDATE THE TEMP PNTR
MOVE T2,NLLCNT(T3) ;AND THE COUNT
MOVEM T2,NLTCNT
JRST NLINLP ;AND TRY AGAIN
NLINOK: ADDM T1,NLTPNT ;UPDATE THE TEMP PNTR
MOVNI T1,(T1) ;MAKE NEGATIVE
ADDM T1,NLTCNT ;AND ADD TO COUNT
POPJ P,
;NLFLST IS THE LIST OF FLAGS ASSOCIATED WITH THE CHARACTERS
;WHICH ARE LEGAL FOR THE FIRST CHARACTER OF A DATA STRING.
;THE SUBROUTINE NLFSRH CHECKS THE FLAGS ASSOCIATED WITH
;THE FIRST CHARACTER OF A DATA STRING AND MATCHES THEM
;AGAINST THE FLAGS IN THIS LIST. THE MATCH LOCATION PROVIDES
;AN INDEX INTO NLTYPE, WHICH PROVIDES A TYPE SPECIFICATION
;(AT LEAST A GUESS...) FOR THE DATA STRING, AND INTO
;NLSUB, WHICH PROVIDES THE SUBROUTINE ADDRESS FOR PROCESSING
;THE DATA STRING. TWO OF THE SUBROUTINES (TDBL AND LOGI) ARE
;ACTUALLY "TRIAL" SUBROUTINES - THEY TRY TO DO THE ACTION
;INDICATED BY THE CHARACTER, BUT MAY END UP DOING SOMETHING
;VERY DIFFERENT INDEED. (FOR GREATER DETAIL, SEE COMMENTS ATTACHED
;TO THOSE SUBROUTINES).
NLFLST: DIGFLG ;DIGIT
PNTFLG ;PERIOD
LOGFLG ;LOGICAL CHAR (T OR F)
SQFLAG ;SINGLE QUOTE
DQFLAG ;DOUBLE QUOTE
LPRFLG ;LEFT PAREN
0
NLTYPE: TP%DPR
TP%DPR ;INITIALLY ASSUME PERIOD IS D.P.
TP%LOG ;INITIALLY ASSUME T OR F IS LOGICAL
TP%LIT
TP%DPO
TP%CPX
NLSUB: %GRIN
TDBL
LOGI
ALPHI
OCTI
CPXI
;THIS IS THE CONVERSION TABLE LIST.
;THE ENTRY POSITION IS DETERMINED BY THE VALUE TYPE. THE LEFT HALF GIVES THE
;NEGATIVE # OF ENTRIES IN THE APPROPRIATE CONVERSION TABLE
;AND THE RIGHT HALF CONTAINS THE ADDRESS OF THE CONVERSION TABLE
CNVLST: 0 ;0 - NO TYPE
LOGCNV-LOGEND,,LOGCNV ;1 - LOGICAL
0 ;2 - INTEGER
0 ;3 -
0 ;4 - SINGLE REAL
0 ;5 -
OCTCNV-OCTEND,,OCTCNV ;6 - SINGLE OCTAL
0 ;7 - LABEL
DRCNV-DREND,,DRCNV ;10 - DOUBLE REAL
0 ;11 - DOUBLE INTEGER
OCTCNV-OCTEND,,OCTCNV ;12 - DOUBLE OCTAL
0 ;13 - EXTENDED DOUBLE REAL
CPXCNV-CPXEND,,CPXCNV ;14 - COMPLEX
0 ;15 - COBOL BYTE STRING
0 ;16 - CHARACTER
ALPCNV-ALPEND,,ALPCNV ;17 - ASCIZ
;NLCFLG IS THE TABLE OF CHARACTER FLAGS. IF A CHARACTER IS WITHIN
;THE RANGE 40-100, THE CHARACTER TESTING ROUTINE NLTST GETS
;THE FLAG ASSOCIATED WITH THAT CHARACTER BY USING THE CHARACTER AS
;AN INDEX INTO THIS TABLE.
NLCFLG: SPCFLG ;SPACE:40
0 ;!:41
DQFLAG ;":42
NSFLAG ;#:43
DOLFLG ;$:44
0 ;%:45
AMPFLG ;&:46
SQFLAG ;':47
LPRFLG ;(:50
RPRFLG ;):51
ASTFLG ;*:52
PLSFLG ;+:53
COMFLG ;COMMA:54
MINFLG ;-:55
PNTFLG ;PERIOD:56
SLHFLG ;/:57
DIGFLG ;0:60
DIGFLG ;1:61
DIGFLG ;2:62
DIGFLG ;3:63
DIGFLG ;4:64
DIGFLG ;5:65
DIGFLG ;6:66
DIGFLG ;7:67
DIGFLG ;8:70
DIGFLG ;9:71
COLFLG ;COLON:72
SEMFLG ;SEMI:73
LABFLG ;<:74
EQUFLG ;=:75
RABFLG ;>:76
0 ;?:77
ATFLAG ;@:100
;THESE ARE THE CONVERSION TABLES. FOR EACH TYPE OF VALUE
;(OCT, LOG, DR, CPX, ALP) THERE IS AN ASSOCIATED TABLE WHICH
;GIVES, FOR EACH TYPE OF VARIABLE, THE APPROPRIATE CONVERSION
;ROUTINE ADDRESS. IN EACH TABLE THE VARIABLE TYPE IS IN THE LEFT
;HALF OF THE WORD AND THE APPROPRIATE CONVERSION ROUTINE ADDRESS
;IS IN THE RIGHT HALF. -1 IN THE LEFT HALF MEANS THAT THE ADDRESS
;IN THE RIGHT HALF IS THE ONE FOR THE
;CONVERSION ROUTINE FOR ALL VARIABLE TYPES (THIS IS TRUE FOR OCTAL
;AND LOGICAL DATA, FOR WHICH THERE IS REALLY NO CONVERSION).
LOGCNV: -1,,DRDR
LOGEND==.
DRCNV: TP%LOG,,DRLOG
TP%INT,,DRINT
TP%SPR,,DRSR
TP%DPR,,DRDR
TP%DPX,,DRDPX
TP%CPX,,DRCPX
DREND==.
CPXCNV: TP%LOG,,CPXLOG
TP%INT,,CPXINT
TP%SPR,,CPXSR
TP%DPR,,CPXDR
TP%DPX,,CPXDPX
TP%CPX,,CPXCPX
CPXEND==.
ALPCNV: TP%LOG,,ALPLOG
TP%INT,,ALPINT
TP%SPR,,ALPSR
TP%DPR,,ALPDR
TP%DPX,,ALPDR
TP%CPX,,ALPCPX
ALPEND==.
OCTCNV: TP%LOG,,DRDR
TP%INT,,DRDR
TP%SPR,,DRSR
TP%DPR,,DRDR
TP%DPX,,DRDR
TP%CPX,,DRDR
OCTEND==.
;THESE ARE THE ACTUAL DATA CONVERSION ROUTINES (BINARY TO
;BINARY FORM). NOTE THAT A "CONVERSION" NEVER DESTROYS
;THE ORIGINAL DATA OR ITS TYPE, BUT MERELY PUTS THE CONVERTED
;VALUE INTO NLCVL. THESE ROUTINES ASSUME THAT
;NLCVL/NLCVL.+1 HAVE BEEN INITIALIZED TO 0 AND THAT NLVAL./NLVAL.+1
;WERE INITIALIZED TO 0 BEFORE DATA WAS READ, SO THAT SINGLE
;PRECISION DATA (LOGIC) WILL YIELD 0 IN NLVAL.+1.
CPXDR:
DRDR:
DMOVE T1,NLVAL.
DMOVEM T1,NLCVL.
POPJ P,
CPXLOG: SKIPN NLINFO ;INFO FROM REAL PART NON-ZERO?
JRST CPXINT ;YES. CONVERT TO INTEGER
;ELSE DROP INTO DRSR
CPXSR:
DRCPX:
DRSR:
DMOVE T1,NLVAL. ;GET VALUE FOUND
PUSHJ P,DSING
MOVEM T1,NLCVL.
POPJ P,
CPXINT: DMOVE T2,NLRFR ;GET SAVED RAW FRACTION
MOVE T4,NLRBX ;AND BINARY EXPONENT
JRST XINT ;JOIN DRINT CODE
DRINT:
DMOVE T2,FL.RFR ;GET LEFT-JUSTIFIED FRACTION
MOVE T4,FL.RBX ;GET BINARY EXPONENT
JUMPLE T4,NOINT ;ZERO IF EXP .LE. 0
XINT: SETZ T1, ;CLEAR INTEGER
CAILE T4,^D35 ;WILL WE SHIFT TO OBLIVION?
JRST INTOVL ;YES. RETURN OVERFLOW
TLNN T3,(1B1) ;HI BIT IN LOW WORD ON?
JRST NORND ;NO
CAME T2,[377777,,777777] ;ABOUT TO OVERFLOW?
AOJA T2,NORND ;NO, ROUND UP
MOVSI T2,200000 ;YES. LOAD A HIGH BIT
AOJA T4,NORND ;AND INCR BIN EXP
NORND: LSHC T1,1(T4) ;SHIFT INTO INTEGER
JUMPL T1,STOINT ;NO NEGATE IF BIT 0 SET
SKIPGE NLVAL. ;NEGATIVE?
MOVN T1,T1 ;YES. NEGATE IT
STOINT: MOVEM T1,NLCVL. ;STORE IT
NOINT: POPJ P,
INTOVL: HRLOI T1,377777 ;RETURN LARGEST NUMBER
MOVEM T1,NLCVL.
$ECALL IOV ;%integer overflow
POPJ P,
DRLOG: SKIPN IO.INF ;ANY DOT OR EXPONENT?
JRST DRINT ;NO. CONVERT TO INTEGER VALUE
JRST DRSR ;YES. CONVERT TO SINGLE
CPXCPX:
DMOVE T1,NLVAL. ;GET VALUE FOUND
PUSHJ P,DSING ;CONVERT TO SR
MOVEM T1,NLCVL. ;SAVE FOR REAL PART
DMOVE T1,NLVL2. ;GET 2ND VALUE FOUND
PUSHJ P,DSING ;CONVERT TO SR
MOVEM T1,NLCVL.+1 ;SAVE FOR IMAGINARY PART
POPJ P,
ALPINT:
ALPLOG:
ALPSR: MOVE T1,SPACES ;MAYBE NULL STRING
SKIPE NLTCNT ;IS IT?
MOVE T1,@NLTPNT ;NO. GET A WORD
MOVEM T1,NLCVL. ;SAVE AS VALUE
POPJ P,
CPXDPX: DMOVE T1,NLRFR ;GET RAW FRACTION
MOVE T3,NLRBX ;AND BINARY EXPONENT
JRST CPDD ;JOIN DRDPX CODE
DRDPX: DMOVE T1,FL.RFR ;GET RAW FRACTION
JUMPE T1,DPXZER ;DO NOTHING WITH ZERO
MOVE T3,FL.RBX ;AND BINARY EXPONENT
CPDD: TLO T1,(1B0) ;PREVENT OVERFLOW
TLO T2,(1B0) ;IN BOTH WORDS
ADDI T2,2000 ;ROUND THE LOW WORD
TLZN T2,(1B0) ;DID WE OVERFLOW?
ADDI T1,1 ;YES. ADD 1 TO HIGH
TLZE T1,(1B0) ;OVERFLOW AGAIN?
JRST DPXNOV ;NO
ASHC T1,-1 ;YES. MOVE RIGHT
ADDI T3,1 ;AND MODIFY THE EXPONENT
TLO T1,(1B1) ;AND TURN ON THE HIGH BIT
DPXNOV: CAIGE T3,2000 ;EXPONENT IN RANGE
CAMG T3,[-2000]
JRST BADEXP ;NO. RETURN OVER OR UNDER
ASHC T1,-^D11 ;MAKE ROOM FOR EXPONENT
ADDI T3,2000 ;MAKE IT EXCESS 2000
DPB T3,[POINT 12,T1,11] ;DEPOSIT THE EXPONENT
SKIPGE NLVAL. ;IS VALUE NEGATIVE?
DMOVN T1,T1 ;YES. GET NEGATIVE
DMOVEM T1,NLCVL. ;SAVE IN CONVERTED FORM
DPXZER: POPJ P,
BADEXP: HRLOI T1,377777 ;LOAD OVERFLOW HIGH
HRLOI T2,377777
JUMPG T3,BADDEP ;DONE IF POS EXP
SETZB T1,T2 ;ZERO IF EXP NEG
BADDEP: DMOVEM T1,NLCVL. ;STORE IN CONVERTED VALUE
POPJ P,
ALPDR:
ALPCPX:
DMOVE T1,SPACES ;MAYBE NULL STRING
SKIPE NLTCNT ;IS IT?
DMOVE T1,@NLTPNT ;NO. GET 2 WORDS
DMOVEM T1,NLCVL. ;SAVE IT
MOVE T1,NLTCNT ;GET THE COUNT
CAILE T1,1 ;ONLY 1 LEFT?
POPJ P, ;NO. WE'RE FINE
MOVE T2,NLTIDX ;YES. GET CURRENT INDEX
ADDI T2,1 ;POINT TO NEXT STRING
MOVE T1,SPACES ;IN CASE IT'S NULL
SKIPE NLLCNT(T2) ;IS IT NULL?
MOVE T1,@NLLPNT(T2) ;NO. GET A WORD
MOVEM T1,NLCVL.+1 ;SAVE IT
POPJ P,
SPACES: ASCII / /
BADCNV: ;IOERR (CCC,799,519,?,Can't convert constant to correct type,,%ABORT)
$ECALL CCC,%ABORT
DSING: CAMN T1,[377777,,777777] ;TOO BIG ALREADY?
JRST DSZERO ;YES. DON'T MAKE IT WORSE
JUMPL T1,DSNEG ;JUMP IF NEGATIVE
TLNE T2,(1B1) ;POSITIVE, ROUNDING REQUIRED?
TRON T1,1 ;YES, TRY TO ROUND BY SETTING LSB
JRST DSZERO ;IT WORKED, DONE
MOVE T2,T1 ;COPY HIGH WORD
AND T1,[777000,,1] ;MAKE UNNORMALIZED LSB WITH SAME EXP
FADR T1,T2 ;ROUND AND NORMALIZE
JRST DSZERO ;DONE
DSNEG: DMOVN T1,T1 ;MAKE POSITIVE
TLNE T2,(1B1) ;NEED ROUNDING?
TRON T1,1 ;YES, TRY TO SET LSB
JRST DSNRET ;IT WORKED, DONE
MOVE T2,T1 ;COPY HIGH WORD
AND T1,[777000,,1] ;MAKE UNNORMALIZED LSB WITH SAME EXP
FADR T1,T2 ;ROUND AND NORMALIZE
DSNRET: MOVN T1,T1 ;PUT SIGN BACK
DSZERO: POPJ P, ;RETURN
;NAMELIST/LDIO MUST HAVE ITS OWN ALPHAMERIC INPUT ROUTINE
;BECAUSE OF THE PROBLEM WITH AN ASSOCIATED REPEAT COUNT, SINCE
;A REPEAT COUNT FORCES US TO KEEP THE ENTIRE STRING AROUND UNTIL
;THE REPEAT COUNT IS EXHAUSTED. THIS ALPHABETIC INPUT ROUTINE
;HAS PROVISION FOR ADDING DYNAMICALLY ALLOCATED MEMORY BEYOND
;THE INITIAL 128 LOCATIONS. SINCE A LIMITED NUMBER OF
;POINTER AND COUNT WORDS ARE AVAILABLE TO KEEP TRACK OF THE
;ALLOCATED CORE, AN INCREASING NUMBER OF
;LOCATIONS ARE REQUESTED EACH TIME WE RUN OUT OF
;CORE (FACTOR OF 2 INCREASE EACH TIME!). SO BY THE TIME
;WE RUN OUT OF POINTER WORDS, 128K HAS BEEN ALLOCATED FOR
;THE ALPHA STRING, WHICH ONE HOPES WOULD BE ENOUGH.
ALPHI: SETZ P2, ;INIT STRING ARRAY INDEX
SETZM NLLTOT ;CLEAR TOTAL
PUSHJ P,SKPCHR ;SKIP THE INITIAL QUOTE
ALPHI0: SKIPE NLLCOR(P2) ;ANY CORE ALLOCATED FOR THIS BUFFER?
JRST ALPHI1 ;YES
MOVEI T1,%ALISZ ;GET INITIAL SIZE
LSH T1,(P2) ;* INDEX**2
MOVEM T1,NLLCOR(P2) ;SAVE THE ALLOCATION
PUSHJ P,%GTBLK ;ALLOCATE THE CORE
MOVEM T1,NLLPNT(P2) ;SAVE THE ADDRESS
ALPHI1: MOVE T1,NLLPNT(P2) ;GET THE ADDRESS
$BLDBP T1 ;Make it a pntr
MOVEM T1,NLTPNT ;SAVE FOR INPUT OF CHARS
MOVE T1,NLLCOR(P2) ;GET THE CORE SIZE
IMULI T1,5 ;GET # CHARS
MOVEM T1,NLTCNT ;AND SAVE IT
ALPLP1: PUSHJ P,GTCHRL ;GET A CHAR
JUMPE T1,ALPLP1 ;IGNORE NULLS
CAIE T1,"'" ;SINGLE QUOTE?
JRST NOTQUO ;NO
PUSHJ P,GTCHRL ;YES. GET ANOTHER
CAIE T1,"'" ;2ND QUOTE?
JRST ENDQUO ;NO
NOTQUO: IDPB T1,NLTPNT ;SAVE THE CHAR
AOS NLLTOT ;INCR PERM TOTAL
SOSLE NLTCNT ;DECR TEMP COUNT
JRST ALPLP1 ;BACK FOR MORE
MOVE T1,NLLCOR(P2) ;THIS BUFFER IS FILLED
MOVEM T1,NLLCNT(P2)
CAIGE P2,%ALASZ ;MORE ARRAY ROOM?
AOJA P2,ALPHI0 ;YES.
; IOERR (STL,799,520,?,Alpha string too long,,%ABORT)
$ECALL STL,%ABORT
ENDQUO:
ALPFIN: MOVE T1,NLLCOR(P2) ;GET ORIG # CHARS
IMULI T1,5
SUB T1,NLTCNT ;GET # CHARS WE GOT
IDIVI T1,5 ;GET REMAINDER IN T2
MOVEM T1,NLLCNT(P2) ;SAVE # WORDS
JUMPE T2,NLNFIL ;NO FILL IF 0
AOS NLLCNT(P2) ;1 MORE WORD IF REMAINDER
SUBI T2,5 ;GET NEG # FILL CHARS
MOVEI T1," " ;FILL WITH BLANKS
ENDLP: IDPB T1,NLTPNT ;DEPOSIT THE FILL CHAR
AOJL T2,ENDLP
NLNFIL: MOVE T1,NLLTOT ;GET # CHARS TOTAL
ADDI T1,4 ;ROUND UP
IDIVI T1,5 ;GET # WORDS
MOVEM T1,NLLTOT ;AND SAVE
MOVE T1,NLLPNT ;GET 1ST PNTR
MOVEM T1,NLTPNT ;SAVE FOR INCR ROUTINE
MOVE T1,NLLCNT ;USE 1ST WORD COUNT
MOVEM T1,NLTCNT ;AS TEMP INIT
SETZM NLLCNT+1(P2) ;NO CHARS IN NEXT BUFFER
SETZM NLTIDX ;CLEAR TEMP INDEX
SETZM NLTTOT ;AND TEMP TOTAL
POPJ P,
;SINCE THERE IS OFFICIALLY NO DIRECT WAY TO READ COMPLEX DATA,
;IT HAS TO BE INVENTED HERE. COMPLEX DATA FOR LIST-DIRECTED I/O
;AND NAMELIST I/O IS DEFINED AS A PARENTHESIZED EXPRESSION
;CONTAINING 2 REAL CONSTANTS, DELIMITED BY A SINGLE COMMA.
CPXI: PUSHJ P,SKPCHR ;THROW AWAY "("
PUSHJ P,GTCHRL ;GET NEXT CHAR
TXNE P1,DQFLAG ;DOUBLE QUOTE?
JRST OCTONE ;YES. GET OCTAL REAL PART
PUSHJ P,%IBACK ;THE CHAR BELONGS TO NUMBER
PUSHJ P,%GRIN ;GET ONE REAL NUMBER
JRST CPXI1
OCTONE: PUSHJ P,OCPXI ;GET OCTAL NUMBER
CPXI1: DMOVE T1,FL.RFR ;SAVE RAW FRACTION
MOVEM T1,NLRFR
MOVE T1,FL.RBX ;AND RAW BINARY EXPONENT
MOVEM T1,NLRBX
PUSHJ P,NLSDEL ;SCAN FOR DELIM
CAIE T1,"," ;WAS IT A COMMA?
$ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
SETOM NLFV. ;SET TO IGNORE THE COMMA
XMOVEI T1,NLVL2. ;GET 2ND DEPOSIT ADDR
MOVEM T1,IO.ADR ;SAVE IT
PUSHJ P,NLNB ;SCAN FOR NEXT DELIM
TXNE P1,DQFLAG ;WAS DELIM DOUBLE QUOTE?
JRST OCTTWO ;YES. GET OCTAL IMAG PART
PUSHJ P,%IBACK ;NO. BACK UP PNTR FOR GRIN
PUSHJ P,%GRIN ;GET 2ND REAL #
JRST CPXI2
OCTTWO: PUSHJ P,OCPXI ;GET OCTAL NUMBER
CPXI2: PUSHJ P,NLSDEL ;GET 2ND DELIM
CAIE T1,")" ;MUST BE A RIGHT PAREN
$ECALL ILC,%ABORT ;"ILLEGAL CHARACTER IN DATA"
PJRST SKPCHR ;THROW AWAY ")"
OCPXI: PUSHJ P,%OCTI ;GET OCTAL NUMBER
MOVE T1,IO.ADR ;GET I/O ADDR
DMOVE T1,(T1) ;GET VALUE
JUMPGE T1,CPXNN ;NEGATE IF NEGATIVE
DMOVN T1,T1
CPXNN: LDB T3,[POINT 9,T1,8] ;GET BINARY EXPONENT
MOVEM T3,FL.RBX ;SAVE AS RAW VALUE
TLZ T1,777000 ;WIPE OUT EXPONENT
ASHC T1,8 ;LEFT-JUSTIFY FRACTION
DMOVEM T1,FL.RFR ;SAVE AS RAW FRACTION
POPJ P,
;LOGI - LOCAL LOGIC INPUT ROUTINE.
;FOR NAMELIST INPUT, IF THE FIRST CHARACTER OF DATA IS A "T"
;OR "F", WE CANNOT BE SURE IF IT IS DATA OR THE
;NAME OF A NEW VARIABLE OR ARRAY TO FILL. SO WE CALL THE LOGIC
;SCANNER AND GET THE DELIMITER FOUND. IF THE DELIMITER IS
;A "=" OR "(" (WHICH ARE CONSIDERED DELIMITERS ONLY FOR NAMELIST,
;NOT FOR LIST-DIRECTED INPUT, IN THE LOGIC SCANNER), WE CALL
;SETNUL, WHICH CHECKS IF SUCH A SITUATION IS LEGAL AND SETS THE
;REST OF THE DATA DESIRED IN THE CURRENT ARRAY TO NULL ITEMS.
;THEN WE STORE THE 1ST SIX CHARACTERS FOUND BY THE LOGIC SCANNER
;FOR USE AS THE NEXT VARIABLE NAME IN THE NAMELIST.
LOGI: PUSHJ P,%LINT ;GET LOGICAL DATA
MOVE T0,FLAGS(D)
TXNE T0,D%LSD ;LIST-DIRECTED INPUT?
POPJ P, ;NO. DON'T SCAN FOR DELIM
PUSHJ P,NLSDEL ;GET THE DELIM
CAIE T1,"(" ;LEFT PAREN OR
CAIN T1,"=" ;EQUAL SIGN?
JRST NOTLOG ;OOPS - IT WAS A NEW VARIABLE
POPJ P, ;NO. IT REALLY WAS LOGIC
NOTLOG: PUSHJ P,SETNL1 ;SET REST OF DATA NULL
MOVE T1,IO.INF ;GET DATA ACCUMULATED
MOVEM T1,NLNAM. ;USE FOR NEW VARIABLE NAME
POPJ P,
;OCTAL INPUT HAS TO THROW AWAY THE INITIAL DOUBLE QUOTE BEFORE
;CALLING THE STANDARD %OCTI ROUTINE
OCTI: PUSHJ P,SKPCHR ;SKIP THE QUOTE
PJRST %OCTI ;AND GO TO STANDARD ROUTINE
;TDBL - TEST FOR DOUBLE REAL - THIS IS CALLED WHEN WE ENCOUNTER
;A PERIOD AS THE FIRST CHARACTER IN THE DATA. SINCE THE DATA
;FOLLOWING CAN BE EITHER REAL (WE ASSUME DOUBLE REAL) OR LOGIC
;(.TRUE., ETC.), WE TRY CALLING %GRIN. IF THE INFORMATION WORD
;REVEALS THAT THERE WERE NO DIGITS AFTER THE PERIOD (IT WILL STOP
;ON THE NEXT CHARACTER IF IT IS NOT A DIGIT), WE MUST ASSUME THAT
;IT IS LOGIC DATA INSTEAD. THEREFORE WE SET THE DATA TYPE TO LOGIC
;AND CALL THE LOGIC INPUT ROUTINE, WHICH WILL BARF APPROPRIATELY
;IF GARBAGE IS FOUND.
TDBL: PUSHJ P,%GRIN ;GET A REAL NUMBER
HRRZ T1,IO.INF ;ANY DIGITS AFTER DOT?
JUMPG T1,%POPJ ;OK IF YES
DSETZM NLVAL. ;NO. RESET VALUE REG
PUSHJ P,%IBACK ;MOVE PNTR TO AFTER DOT
MOVEI T1,TP%LOG ;AND ASSUME IT'S LOGICAL
MOVEM T1,VALTYP
PJRST %LINT
;NAMELIST OUTPUT - OUTPUTS ALL VARIABLES AND ARRAYS IN THE
;NAMELIST IN THE ORDER IN WHICH THEY APPEAR IN THE NAMELIST.
;BOTH VARIABLES AND NAMELIST NAMES ARE DELIMITED WITH
;COMMAS. THERE IS NO TRAILING COMMA!
%NLO: PUSHJ P,NLINIT ;INITIALIZE STUFF
MOVX T0,D%IO+D%NML ;SET FOR NMLST OUTPUT
IORM T0,FLAGS(D)
MOVEI T1,1 ;SET FOR 1PG OUTPUT
MOVEM T1,SCL.SV
PUSHJ P,CHKEND ;MAKE SURE COL 1
PUSHJ P,SPCOUT ;ADVANCE TO COL 2
MOVEI T1,"$" ;OUTPUT $
PUSHJ P,PUTCHR
MOVE T1,NLARG. ;GET NMLST ADDR
MOVEM T1,NLVAR. ;SAVE IT
MOVE T1,(T1) ;GET NAMELIST NAME
MOVEM T1,NLNAM. ;SAVE FOR OUTPUT
PUSHJ P,NLONAM ;OUTPUT IT
PUSHJ P,%ORECS ;EOL
MOVEI T1,1 ;ADD 1 TO NMLST ADDR
ADDM T1,NLVAR. ;TO GET 1ST VARIABLE PNTR
NLOLP: SKIPE T1,@NLVAR. ;ANY MORE VARS?
CAMN T1,FINCOD ;OR END CODE?
JRST NLOEND ;END OF LIST
PUSHJ P,VARSET ;SETUP VARIABLE PARAMS
MOVEI T1,^D8 ;MAKE ROOM FOR NAME AND "="
MOVEM T1,OSIZE
PUSHJ P,PUTCOM ;OUTPUT COMMA, CHECK LINE
PUSHJ P,NLONAM ;OUTPUT VARIABLE NAME
MOVEI T1,"=" ;OUTPUT =
PUSHJ P,PUTCHR
SETZM NLFLG. ;AVOID COMMA BEFORE 1ST DATA
PUSHJ P,NLMO ;MAIN OUTPUT ROUTINE
SETOM NLFLG. ;SET FLAG FOR OUTPUT STARTED
MOVEI T1,2 ;ASSUME SCALAR
ADDM T1,NLVAR. ;FOR INCR TO NEXT VARIABLE
MOVE T1,NLDIM. ;GET # DIMS
JUMPE T1,NLOLP ;CORRECT IF SCALAR
ADDI T1,1 ;ADD # DIMS +1 IF ARRAY
ADDM T1,NLVAR.
JRST NLOLP ;BACK FOR MORE
NLOEND: PUSHJ P,CHKEND ;EOL
PUSHJ P,SPCOUT ;OUTPUT SPACE
MOVEI T1,"$" ;OUTPUT $
PUSHJ P,PUTCHR
MOVEI T1,"E" ;OUTPUT E
PUSHJ P,PUTCHR
MOVEI T1,"N" ;OUTPUT N
PUSHJ P,PUTCHR
MOVEI T1,"D" ;OUTPUT D
PUSHJ P,PUTCHR
PJRST %ORECS ;EOL AGAIN
FINCOD: 4000,,0 ;NAMELIST END CODE
;FOR F10 VERSION 2 AND UP
;NLMO - NAMELIST AND LIST-DIRECTED MAIN OUTPUT ROUTINE.
;OUTPUTS A VARIABLE BY ITS TYPE; CHECKS FOR A REPEATED VALUE;
;IF THE REPEAT COUNT IS 1 IT IS NOT PRINTED. IF THE REMAINING
;NLNUM. IS NON-ZERO, A COMMA IS PRINTED AND THE PROCESS IS
;REPEATED.
NLMO: SKIPN NLNUM. ;MAKE SURE THERE'S DATA
POPJ P, ;LEAVE IF NONE
NLMOLP: MOVE T1,VARTYP ;GET VARIABLE TYPE
MOVE T1,OSIZTB(T1) ;GET SIZE OF DATA
MOVEM T1,OSIZE ;MAKE ROOM FOR IT
PUSHJ P,PUTCOM ;CHECKS CUR POS AND DATA SIZE
PUSHJ P,NLCRP ;CHECK FOR A REPEATED VALUE
MOVE T1,NLRP. ;GET THE REPEAT COUNT
CAILE T1,1 ;IS IT 1?
PUSHJ P,NLORP ;.GT.1. OUTPUT WITH *
XMOVEI T1,NLVAL. ;POINT TO VALUE
MOVEM T1,IO.ADR ;SAVE ADDR
MOVE T1,VARTYP ;GET VARIABLE TYPE
MOVEM T1,IO.TYP ;SAVE IT
PUSHJ P,@OUTSUB(T1) ;OUTPUT THE VALUE
SETOM NLFLG. ;SET DATA OUTPUT DONE
SKIPE NLNUM. ;ANY MORE?
JRST NLMOLP ;YES. BACK FOR MORE
POPJ P, ;NO
;NLCRP - ROUTINE TO CHECK FOR A REPEATED VALUE
;PLACES THE (SINGLE OR DOUBLE WORD) VALUE POINTED TO BY
;NLVAL. AND THEN INCREMENTS A LOCAL POINTER AND CHECKS
;THE NEXT ENTRY FOR AN IDENTICAL VALUE; THIS PROCESS IS
;CONTINUED UNTIL A NON-MATCH IS FOUND. THE ADDRESS OF THE
;NON-MATCHING ENTRY IS SAVED IN NLADD., THE NUMBER OF
;REPEATED VALUES IS PLACED IN NLRP., AND NLNUM. IS
;DECREMENTED APPROPRIATELY.
;NOTE THAT THERE IS NO WAY FOR THIS ROUTINE TO CHECK FOR
;VALUES THAT DIFFER BEYOND THE OUTPUT ACCURACY (AND THEREFORE
;PRINT THE SAME), NOR DOES THIS ROUTINE CHECK FOR IDENTICAL
;VALUES ACROSS DIFFERENT VARIABLES.
NLCRP: MOVEI T1,1 ;ASSUME REPEAT COUNT OF 1
MOVEM T1,NLRP.
SETZ T2, ;CLEAR 2ND VALUE WORD
MOVE T3,NLSIZ. ;GET SIZE
XCT NLGET(T3) ;GET THE VALUE
DMOVEM T1,NLVAL. ;SAVE IT
NLCLP: MOVE T1,NLINC. ;INCR ADDR
ADDM T1,NLADD.
SOSG NLNUM. ;ANY MORE ENTRIES?
POPJ P, ;NO. LEAVE
SETZ T2, ;CLEAR 2ND VALUE WORD
XCT NLGET(T3) ;GET NEXT ENTRY
CAMN T1,NLVAL. ;COMPARE
CAME T2,NLVAL.+1
POPJ P, ;THEY DIDN'T MATCH
AOS NLRP. ;THEY DID. INCR RPT COUNT
JRST NLCLP ;AND TRY AGAIN
;NLONAM - OUTPUT A SIXBIT NAME
NLONAM: MOVE T1,[POINT 6,NLNAM.] ;GET PNTR
MOVEM T1,NLVAL. ;SAVE IT
MOVEI T1,6 ;MAX COUNT
MOVEM T1,NLRP. ;SAVE IT
NLONLP: ILDB T1,NLVAL. ;GET CHAR
JUMPE T1,NLONF ;DONE IS 0
ADDI T1,40 ;CONVERT TO ASCII
PUSHJ P,PUTCHR ;OUTPUT IT
SOSLE NLRP. ;DECR COUNT
JRST NLONLP ;BACK FOR MORE
NLONF: POPJ P,
;NLORP - OUTPUT REPEAT COUNT AND *
NLORP: XMOVEI T1,NLRP. ;GET REPEAT COUNT ADDR
MOVEM T1,IO.ADR ;SAVE IT
PUSHJ P,%INTO ;OUTPUT IT
MOVEI T1,"*" ;OUTPUT *
PJRST PUTCHR
;PUTCHK - CHECK LINE - USED FOR DELIMITING DATA ITEMS
;AND VARIABLE NAMES IN THE OUTPUT STREAM. IF THE LINE OF OUTPUT
;IS ABOUT TO BE "TOO LONG" (DEFINED BY TTYW MINUS DATA SIZE
;FOR THE NEXT ITEM) A NEW LINE IS STARTED.
PUTCHK: PUSHJ P,%RPOS ;GET CURRENT POSITION
ADD T1,OSIZE ;ALLOW ROOM FOR VALUE
LOAD T2,TTYW(D) ;GET WIDTH
CAIG T1,(T2) ;WOULD IT OVERFLOW WIDTH?
AOS (P) ;NO. SKIP RETURN
POPJ P,
;PUTCOM - OUTPUT COMMA IF PREV OUTPUT, CHECK FOR LINE-TOO-LONG, AND
;OUTPUT SPACE.
PUTCOM: MOVEI T1,"," ;OUTPUT COMMA
SKIPE NLFLG. ;ONLY IF PREVIOUS DATA
PUSHJ P,PUTCHR
PUSHJ P,PUTCHK ;WILL WE OVERFLOW LINE?
SPCEOL: PUSHJ P,%ORECS ;YES. OUTPUT EOL
SPCOUT: MOVEI T1," " ;PLUS A SPACE
PJRST PUTCHR
;CHKEND - TO MAKE SURE THAT WE ARE AT THE BEGINNING OF THE LINE
;WHEN WE OUTPUT THE NAMELIST "BEGIN STRING" - A SPACE
;AND DOLLAR SIGN.
;PUTEND - FORCES OUTPUT OF LAST RECORD AND STARTS NEW LINE
CHKEND: PUSHJ P,%RPOS ;GET CURRENT POSITION
CAIN T1,1 ;NEW LINE?
POPJ P, ; YES, QUIT
PJRST %ORECS ;NO, FORCE EOL
;WE HAVE FUNNELED ALL OUTPUT CHARACTER CALLS THROUGH HERE, SO THAT IF SOMEDAY
;SOMEONE WANTS SOMETHING SPECIAL DONE WHICH IS NOT PART OF %OBYTE, IT CAN BE
;DONE HERE AND BE GLOBAL FOR ALL OF NAMELIST OUTPUT.
PUTCHR==%OBYTE
;THIS IS THE TABLE OF "OUTPUT SUBROUTINES BY TYPE". THE VARIABLE
;TYPE IS USED AS THE INDEX INTO THE TABLE.
OUTSUB: IFIW %INTO ;0 NOT SPECIFIED
IFIW %LOUT ;1 LOGICAL
IFIW %INTO ;2 INTEGER
IFIW NONO ;3
IFIW %GROUT ;4 SINGLE REAL
IFIW NONO ;5
IFIW %OCTO ;6 SINGLE OCTAL
IFIW NONO ;7 STATEMENT LABEL
IFIW %GROUT ;10 DOUBLE REAL
IFIW NONO ;11 DOUBLE INTEGER
IFIW %OCTO ;12 DOUBLE OCTAL
IFIW %GROUT ;13 EE DOUBLE REAL
IFIW CPXO ;14 COMPLEX
IFIW NONO ;15 COBOL BYTE STRING
IFIW NONO ;16
IFIW NONO ;17 ASCIZ
NLGET: JFCL
MOVE T1,@NLADD.
DMOVE T1,@NLADD.
;OUTPUT DATA ELEMENT SIZE TABLE - GIVES MAXIMUM SIZE OF A DATA ELEMENT
;BASED ON ITS DATA TYPE
OSIZTB: ^D14 ;0 (BADLY SPECIFIED INTEGER)
3 ;1 LOGICAL
^D14 ;2 INTEGER
0 ;3
^D16 ;4 REAL
0 ;5
0 ;6
0 ;7
^D16 ;10 DOUBLE REAL
0 ;11
0 ;12
^D16 ;13 EE DOUBLE REAL
^D32 ;14 COMPLEX
0 ;15
0 ;16
0 ;17
;CPXO - SIMILAR TO CPXI - SINCE THERE IS NO OFFICIAL ROUTINE
;FOR COMPLEX VARIABLE OUTPUT, WE HAVE TO DO IT HERE, SENDING
;EACH PART OUT THROUGH %GROUT (WHICH MUST BE FOOLED INTO
;THINKING THE VARIABLE TYPE IS SINGLE REAL...).
CPXO: MOVEI T1,TP%SPR ;MAKE THE TYPE SINGLE REAL
MOVEM T1,IO.TYP
MOVEI T1,"(" ;OUTPUT LEFT PAREN
PUSHJ P,PUTCHR
PUSHJ P,%GROUT ;OUTPUT REAL PART
MOVEI T1,TP%SPR ;USE REAL DATA SIZE
MOVE T1,OSIZTB(T1) ;FROM SIZE TABLE
MOVEM T1,OSIZE ;TO CHECK FOR ENOUGH ROOM
MOVEI T1,"," ;OUTPUT COMMA
PUSHJ P,PUTCHR
PUSHJ P,PUTCHK ;AND CHECK FOR LINE-TOO-LONG
PUSHJ P,SPCEOL ;IN WHICH CASE OUTPUT EOL
XMOVEI T1,NLVAL.+1 ;OUTPUT IMAGINARY PART
MOVEM T1,IO.ADR ;SAVE FOR OUTPUT
PUSHJ P,%GROUT
MOVEI T1,")" ;OUTPUT RIGHT PAREN
PJRST PUTCHR
NONO: $SNH ;NONEXISTENT OUTPUT ROUTINE
PURGE $SEG$
END