Google
 

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