Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

; UPD ID= 3470 on 3/26/81 at 9:51 AM by NIXON                           
TITLE	ACCEPT FOR LIBOL V12C

	SEARCH COPYRT
	SALL


COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1973, 1985
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE.

		SEARCH	LBLPRM		;GET PARAMETERS
IFN TOPS20,<	SEARCH	MACSYM,MONSYM>
IFE TOPS20,<	SEARCH	MACTEN,UUOSYM>
IFN LSTATS,<	SEARCH	METUNV		;LSTATS METER DEFINITIONS>

;**** version 12B
;[1074] 19-AUG-83 JEH	Fix twos complement routine
;[1041]	20-AUG-82 RLF	Makes SIZE ERROR work when ACCPETed data item
;			is multiplied by a constant.
;[553] 19-FEB-79 DAW  ALLOW NO DIGITS FOLLOWING A DECIMAL POINT	
;[441]  6/25/76  EHM  PUT $ IN FRONT OF ERROR MESAGE SO IT WILL GO 
;		 TO OPR UNDER BATCH.
;**; EDIT 337 ALLOW MORE THAN ONE DATA TO BE ENTERED ON A LINE.

HISEG

	.COPYRIGHT		;Put standard copyright statement in REL file

;CALLING SEQUENCE IS PUSHJ PP, ACEPT. WITH THE CALLING UUO IN AC 16.
;THE UUO'S EFFECTIVE ADDRESS CONTAINS A PARAMETER WORD.
;
;ALPHA:	  BIT 6 IS ZERO, ACCEPT AN ALPHANUMERIC TERM.
;	  THE PARAMETER WORD IS A MODIFIED BYTE POINTER TO THE
;	  BUFFER AREA. MODIFICATIONS FOLLOW:
;	  IF BIT 7 IS SET THIS IS THE LAST FIELD, SKIP TO A EOL
;	    CHARACTER (LF,VT,FF,CR).
;	  BITS 8-17 CONTAIN THE NUMBER OF CHARACTERS TO ACCEPT.
;
;NUMERIC: BIT 6 IS SET, ACCEPT A NUMERIC TERM.
;	  THE PARAMETER WORD IS INTERPRETED AS FOLLOWS:
;	  IF BIT 7 IS SET THIS IS THE LAST FIELD, SKIP TO AN
;	    EOL CHARACTER.
;	  BITS 8-17 CONTAIN THE FIELD SIZE,THE NUMBER OF NUMBERS
;	    TO ACCEPT.
;	  IF BIT 18 IS SET, THEN ITEM IS PIC PPP..99.. AND
;	    HIGH ORDER DIGITS ARE ZEROED OUT.
;	  IF BIT 19 IS SET, THEN ITEM IS COMP-1. RETURN AC0= FLOATING
;	    POINT NUMBER.
;	  IF BIT 30 IS A ZERO, THEN BITS 31-35 CONTAIN THE NUMBER
;	    OF DECIMAL PLACES IN THE FIELD SIZE.
;	  IF BIT 30 IS SET, THEN BITS 31-35 CONTAIN A SCALE
;	    FACTOR.  THE AMOUNT OF NUMBERS ACCEPTED BECOMES
;	    (FIELD SIZE)+(SCALE FACTOR) AND UPON COMPLETION
;	    (SCALE FACTOR) CHARACTERS ARE TRUNCATED FROM THE
;	    RIGHT.  THE PERIOD BECOMES AN ILLEGAL CHARACTER.
;MODIFIED ACS ARE:	17,15,11,10,7,6,3,2,1,0

PP=	17	;PUSHDOWN LIST POINTER
AC16=	16	;THE CALLING UUO
AC15=	15	;UUO'S OPERAND
C=	AC10+1	;CRARACTER REGISTER
AC10=	10	;FIELD COUNT
FLG=	7	;FLAG REGISTER
AC6=	6	;CHARACTER COUNT
AC1=	1	;LSTATS TEMP REGISTER
AC2=	2	;LSTATS ARG REGISTER

MINUS=	400000	;A MINUS SIGN WAS SEEN
SIGN=	200000	;A PLUS OR MINUS SIGN WAS SEEN
PERIOD=	100000	;A DECIMAL POINT WAS SEEN
NUMBER=	 40000	;A NUMBER WAS SEEN
ASCALE=  20000	;ITEM WAS PICTURE PPP...999 - JUST RETURN LOW ORDER DIGITS.

ENTRY	ACEPT.
EXTERN	GETCH.,DOPFS.,FLDCT.,POINT.
EXTERN	DSPL1.,RET.1,RET.2,OUTCH.
IFN LSTATS,<
IFN TOPS20,<
EXTERN	MRTM.E
>
EXTERN MRACDP
EXTERN	MRTMB.,MBTIM.
>
MLON
SALL

DEFINE	TYPE(ADDR),<
 IFE TOPS20,<
	OUTSTR	ADDR
 >;TOPS10 STYLE
 IFN TOPS20,<
	PUSH	PP,1
	HRROI	1,ADDR
	PSOUT%
	POP	PP,1
 >;TOPS20 STYLE, BE REALLY CAREFUL
>;END DEFINE "TYPE"

DEFINE $CLRIB,<	;CLEAR INPUT BUFFER ON TTY
REPEAT 0,<		;IN V13
 IFE TOPS20,<
	CLRBFI		;TOPS10 UUO TO CLEAR TTY BUFFER
 >
 IFN TOPS20,<
	PUSH	PP,T1		;BE REAL CAREFUL
	MOVEI	T1,.PRIIN	;CLEAR PRIMARY INPUT'S BUFFER
	CFIBF%
	POP	PP,T1		;RESTORE SAVED AC
 >
>;END REPEAT 0 FOR V13
REPEAT 1,<
	CLRBFI			;[12B] STILL NOT NATIVE
>
>;END DEFINE $CLRIB

ACEPT.:
IFN LSTATS,<
	MOVEI	AC2,MB.ACP		;INDICATE ACCEPT METER POINT
	PUSHJ	PP,MRACDP		;SET ACCEPT METER BUCKET
>
	MOVE	AC15,(AC16)		;(AC16)=	UUO	AC,E
	LDB	AC6,DOPFS.		;001777 000000  FIELD SIZE
	TXNN	AC15,ACP%LF		;SKIP TO END OF LINE?
	AOSA	AC10,FLDCT.		;NO-INCREMENT
	SETZB	AC10,FLDCT.		;YES-LAST FIELD
	TXNN	AC15,ACP%NM		;SKIP IF NUMERIC
	JRST	ALPHA			;JUMP IF ALPHA
	SETZB	0,1			;ANSWER RETURNED IN 0 AND 1
	SETZ	FLG,			;CLEAR THE FLAGS
	TXNE	AC15,ACP%FP		;FLOATING POINT INPUT?
	JRST	.FLIN			;YES
	TXZE	AC15,ACP%P9		;PIC P9?
	TLO	FLG,ASCALE		;YES, REMEMBER TO THROW AWAY HIGH-ORDER
					; DIGITS BEFORE WE RETURN
	TXNN	AC15,ACP%SF		;SKIP IF THERE IS A SCALE FACTOR
	JRST	ACEPT1			;
	ADDI	AC6,-ACP%SF(AC15)	;FIELD SIZE PLUS SCALE FACTOR
	JRST	DISPCH			;
ACEPT1:	SUBI	AC6,(AC15)		;FIELD SIZE MINUS DECIMAL PLACES
	JRST	DISPCH			;

AMINUS:	TLO	FLG,MINUS		;MINUS=	1B0
APLUS:	TLNE	FLG,PERIOD!NUMBER!SIGN
	JRST	ILLFMT			;THE SIGN MUST PRECEDE PERIOD AND NUMBERS
	TLO	FLG,SIGN
	JRST	DISPCH

TERMIN:	TLNE	FLG,NUMBER		;SKIP ON NULL FIELD
	JRST	TERM10			;JUMP IF A NUMBER WAS SEEN.
	TLNE	FLG,SIGN!PERIOD
	JRST	ILLFMT			;NULLS MUST BE UNSIGNED INTEGERS
	CAIL	C,-1			;SKIP IF NOT SPACE OR TAB 
	JRST	DISPCH			;LEADING SPACES AND TABS ARE NOT TERMINATORS

TERM10:	TRZN	AC15,40			;SKIP IF SCALE FLAG IS SET
	JRST	TERM11
	HRRZ	AC6,AC15		;DECIMAL PLACES TO AC6
DIV10:	MOVE	2,1	
	IDIVI	0,^D10	
	DIVI	1,^D10	
	SOJG	AC6,DIV10
	JRST	TERM20
TERM11:	TLNN	FLG,PERIOD		;SKIP IF A PERIOD WAS SEEN
	HRRZ	AC6,AC15		;FRACTIONAL PLACES
	JUMPE	AC6,TERM20		;JUMP IF ZERO FILL IS NOT NEEDED
	PUSHJ	PP,MUL10		;GET A ZERO
	SOJG	AC6,.-1			;TILL AC6=0
TERM20:	JFCL	17,.+1			;[1041] CLEAR ALL FLAGS
	TLNE	FLG,ASCALE		;IF ASCALE IS SET,
	 JRST	TERM22			; RETURN LOW-ORDER DIGITS
TERM21:	JUMPGE	FLG,GETEOL		;JUMP IS SIGN IS POSITIVE
	SETCA	1,			;IT'S NEGATIVE SO
	SETCA	0,			;COMPLEMENT THE
	JCRY1	.+1			;[1074] CLEAR FLAGS
	AOS	1			;[1074] ONE ADD TO LOW ORDER WORD
	JCRY1	[TLZ	1,400000	;[1074] SHUT OFF CARRY FLAG
		 AOJA	0,GETEOL]	;[1074] AND ADD ONE
	JRST	GETEOL			;[1074]

; HERE IN THE CASE WHERE THE PICTURE WAS PPPP...9999.
; WE MUST MAKE SURE ALL DIGITS WHERE THE P'S ARE WILL BE 0'S.
; DIVIDE BY THE FIELD SIZE (# OF 9'S) AND JUST RETURN THE REMAINDER.
;(RESULT - IF PIC P9 AND HE TYPED ".34", RETURN ".04")

TERM22:	LDB	AC15,DOPFS.		;GET FIELD SIZE (# DIGITS TO SAVE)
	CAILE	AC15,^D10		;IS POWER OF 10 ONE WORD?
	 JRST	BIG			;NO - SPLIT
	MOVE	2,1
	IDIV	0,DECTAB##(AC15)	;DECTAB IS DEFINED IN PD.MAC
	DIV	1,DECTAB##(AC15)	; GET FINAL 1 WORD REMAINDER IN 2
	SETZ	0,			;HIGH ORDER WORD WILL BE 0
	MOVE	1,2			;RETURN REMAINDER
	JRST	TERM21			; (DONE)

BIG:	SUBI	AC15,^D10		;GET SOMETHING SMALLER
	MOVE	2,1
	DIV	0,DECTAB+^D10		;DIVIDE NUMBER BY 10**10
	IDIV	1,DECTAB+^D10		;1-WORD REMAINDER IN 2
	MOVE	AC6,2			;SAVE AWAY 1ST REMAINDER
	MOVE	1,0			;FETCH 1-WORD QUOTIENT
	IDIV	1,DECTAB(AC15)		;NOW GET HIGH-ORDER REMAINDER
	MOVE	0,DECTAB+^D10		;GET 10**10
	MUL	0,2			;MULTIPLY BY HIGH ORDER REMAINDER
	TLO	AC6,(1B0)		;DON'T ALLOW OVERFLOW
	ADD	1,AC6			; ADD IN LOW-ORDER REMAINDER
	TLZN	1,(1B0)			;IF BIT WAS CLEARED, SIMULATE OVERFLOW
	 ADDI	0,1
	JRST	TERM21			;THEN DONE

MUL10:	ASHC	0,1			;MULTIPLY THE ANS BY 10
	MOVE	3,1			;
	MOVE	2,0			;
	ASHC	2,2			;(ANS*2)*4
	ADDM	2,0			;(ANS*8)+ANS*2
	JCRY1	.+1			;CLEAR OVR-FLO
	ADDM	3,1			;ANS*10
	JCRY1	[TLZ 1,400000		;TURN OFF FALSE CARRY
		 AOJA 0,.+1]		;BUT SAVE THE CARRY OUT
	POPJ	PP,

APERIO:	TRNN	AC15,40			;SKIP IF SET, FRACTIONS ARE NOT ALLOWED
	TLOE	FLG,PERIOD		;SKIP IF THIS IS FIRST PERIOD
	JRST	ILLFMT			;ONLY ONE DECIMAL POINT PER NUMBER
	HRRZ	AC6,AC15		;FRACTIONAL PLACES
	JRST	DISPCH			;[553] GO GET NEXT CHARACTER
ANUMBE:	TLO	FLG,NUMBER		;SAW A NUMBER
	PUSHJ	PP,MUL10		;MAKE ROOM FOR NEXT NUMBER
	ANDI	C,17			;CONVERT ASCII TO OCTAL
	ADDM	C,1			;ADD IN THE OCTAL NUMBER
	JCRY1	[AOJA 0,.+1]		;AND DON'T LOSE THE CARRY OUT BIT
	SOJL	AC6,ILLFMT		;EXTRA NUMBERS ARE ILLEGAL.

DISPCH:	PUSHJ	PP,GETCH.		;DISPATCH TO ONE OF FIVE ROUTINES
	  JRST	TERMIN			;ALT-MODE, FF, VT OR LF
	MOVE	3,POINT.		;
	CAIN	C,40(3)			;"." OR ","
	JRST	APERIO			;   IS A PERIOD
	CAILE	C,"9"
	JRST	ILLFMT			;ELSE ILLEGAL FORMAT
	CAIL	C,"0"
	JRST	ANUMBE			;"0" THROUGH "9"
	CAIE	C,11
	CAIN	C,40
	AOBJP	C,TERMIN		;TAB OR SPACE
	SUBI	C,53
	JUMPE	C,APLUS			;PLUS
	SOJE	C,TERMIN		;COMMA
	SOJE	C,AMINUS		;MINUS

ILLFMT:	SOS	FLDCT.			;DECREMENT THE FIELD COUNT
	$CLRIB				;EMPTIES THE BUFFER
	TYPE	[ASCIZ/$LBLILF Illegal format, retype /] ;[441]SEND TO OPR IN BATCH
	CAIE	AC10,0
	 JRST	STRTNG			;NOT THE LAST FIELD
	TYPE	[ASCIZ/the last field.
/]
	JRST	ACEPT.			;TRY AGAIN
STRTNG:	TYPE	[ASCIZ/starting with field /]
	PUSHJ	PP,OCTDCI		;OUTPUT THE FIELD NUMBER
	PUSHJ	PP,DSPL1.		;OUTPUT BUFFER "CRLF"
	JRST	ACEPT.			;AND START ALL OVER AGAIN

OCTDCI:	IDIVI	AC10,^D10			;OCTAL TO DECIMAL CONVERSION
	HRLM	C,(PP)			;SAVE REMAINDERS ON PDLIST
	CAIE	AC10,0			;SKIP IF QUOTIENT = 0
	PUSHJ	PP,OCTDCI		;PICK OFF THE NEXT REMAINDER
	HLRZ	C,(PP)			;POP OFF THE LAST REMAINDER
	ADDI	C,"0"			;ASCIIZE IT
	JRST	OUTCH.			;AND TYPE IT

;AC6 HOLDS THE FIELD SIZE
;AC15 HOLDS A MODIFIED BYTE POINTER

ALPHA:	TLZ	AC15,7777
	TLO	AC15,700		;AC15 IS NOW A NORMAL BYTE POINTER
ALPGET:	PUSHJ	PP,GETCH.		;GET NEXT CHARACTER
	  JRST	ALPFIL			;TERMINATOR
	CAIN	C,32			;CONTROL Z?
	JRST	ALPGET			;(CONTROL Z)'S ARE IGNORED
	IDPB	C,AC15			;IT'S OK
	SOJLE	AC6,GETEO1		;JUMP WHEN CHARACTER COUNT GOES TO ZERO [337]
	JRST	ALPGET			;

ALPFIL:	MOVEI	C,40			;FILL OUT THE FIELD WITH SPACES
	IDPB	C,AC15
	SOJG	AC6,.-1
	MRTME.	(AC1)			;END METER TIMING
	POPJ	PP,			;EXIT

GETEOL:
IFN LSTATS,<
	JUMPN	AC10,GETEOX		;END TIMING AND EXIT
>
IFE LSTATS,<
	JUMPN	AC10,RET.1		;JUMP IF NOT ZERO [337]
>
GETEO1:	CAIE	C,12			;SKIP IF EOL CHAR
	PUSHJ	PP,GETCH.		;EXIT ON EOL CHAR.
IFE LSTATS,<
	  POPJ	PP,			;EOL = ALT-MODE, FF, VT OR LF
>
IFN LSTATS,<
	  JRST	GETEOX			;END TIMING BEFORE EXIT
>
	JRST	GETEO1			; LOOP [337]
IFN LSTATS,<
GETEOX:	MRTME.	(AC2)			;END METER TIMING
	POPJ	PP,			;EXIT
>

SUBTTL	FLOATING POINT INPUT	D.M.NIXON	6-APR-77

	SALL


REPEAT 0,<
	EXTERN	LOTEN$
>;END REPEAT 0 FOR DOUBLE PRECISION
	EXTERN	HITEN$,EXP10$,PTLEN$

;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 OR 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.

A=0
B=A+1			;RESULT RETURNED IN A OR A AND B
CC=B+1			;B,C, AND D ARE USED AS A MULTIPLE PRECISION
D=CC+1			;  REGISTER FOR DOUBLE PRECISION OPERATIONS
;D+1
FM=5
XP=6			;EXPONENT AFTER D OR E
ST=13			;STATES
;ST+1			;TEMPORARY
BXP==ST			;BINARY EXPONENT
X=15			;COUNTS DIGITS AFTER POINT
P=17			;PUSHDOWN POINTER


;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)
DIGSN==20		;DIGIT SEEN

;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

OPDEF	JUMPDP	[JUMPL	FLG,]

.FLIN:	SETZB	FM,FLG		;NO FORMAT WORD, SINGLE PRECISION
	PUSHJ	P,FLIRT%
	 JRST	ILLFMT		;ILLEGAL FORMAT
	JRST	GETEOL		;GET EOL IF NECESSARY, THEN EXIT

REPEAT 0,<

.DFIN:	SETZ	FM,		;NO FORMAT WORD
	MOVSI	FLG,(1B0)	;DOUBLE PRECISION
	PUSHJ	P,FLIRT%
	  POPJ	P,
	AOS	(P)
	POPJ	P,
>;END REPEAT 0 FOR DOUBLE PRECISION

FLIRT%:				;INPUT
	SETZB	B,CC		;INIT D.P. FRACTION
	SETZB	ST,XP		;INIT STATE AND DECIMAL EXPONENT
	SETZB	X,ST+1		;INIT "DIGITS AFTER POINT" COUNTER
	SETZ	A,

GETNXT:	LSH	ST,-^D30	;MOVE STATE TO BITS 30-32
	PUSHJ	P,GETCH.	;GET NEXT CHARACTER
	  TRN			;EOL CHARACTER (FLIRT% KNOWS ABOUT IT)
	CAIL	C,"0"		;CHECK FOR NUMBER
	CAILE	C,"9"
	JRST	CHRTYP		;NO, TRY OTHER
	SUBI	C,"0"		;CONVERT TO NUMBER
	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
	XCT	XCTTAB(ST)	;DISPATCH OR EXECUTE
	JRST	GETNXT		;RETURN FOR NEXT CHAR.

XCTTAB:	JRST	ILLCH		; (00) ILLEGAL CHAR
	JRST	ENDF0		; (01) CR-LF
	IORI	FLG,DOTFL	; (02) PERIOD
	JRST	DIG		; (03) DIGIT BEFORE POINT
	JRST	BLNKIN		; (04) BLANK OR TAB
	JRST	GETNXT		; (05) RETURN FOR NEXT CHAR.
	IORI	FLG,MINFR	; (06) NEGATIVE FRACTION
	IORI	FLG,MINEXP	; (07) NEGATIVE EXP
	SOJA	X,DIG		; (10) DIGIT AFTER POINT
	JRST	DIGEXP		; (11) EXPONENT
	JRST	DELCK		; (12) DELIMITER TO BACK UP OVER
	JRST	ILLFST		; (13) ILLEGAL FIRST CHARACTER

CHRTYP:	CAIN	C,"+"		;CONVERT INPUT CHARS TO CHARACTER TYPE
	IORI	ST,PLSTYP
	CAIN	C,"-"
	IORI	ST,MINTYP
	CAIE	C," "		;SPACE
	CAIN	C,"	"	;TAB
	IORI	ST,SPCTYP
	CAIN	C,"."
	IORI	ST,DOTTYP
	CAIE	C,"D"
	CAIN	C,"E"
	IORI	ST,EXPTYP
	CAIE	C,"d"
	CAIN	C,"e"
	IORI	ST,EXPTYP
	CAIN	C,12		;CARRIAGE-RETURN?
	IORI	ST,CRTYP
	JRST	GOTST		;GO DISPATCH ON OLD STATE AND CHAR TYPE


DIG:	TRO	FLG,DIGSN	;SAW A DIGIT
	JUMPN	B,DPDIG		;NEED D.P. YET?
	CAMLE	CC,MAGIC	;NO, WILL MUL AND ADD CAUSE OVERFLOW?
	JRST	DPDIG		;MAYBE, SO DO IT IN DOUBLE PRECISION
	IMULI	CC,12		;NO, MULTIPLY BY 10 SINGLE PRECISION
	ADD	CC,C		;ADD DIGIT INTO NUMBER
	JRST	GETNXT		;GO GET NEXT CHARACTER

DPDIG:	CAMLE	B,MAGIC		;WILL MULTIPLY AND ADD CAUSE OVERFLOW?
	AOJA	X,GETNXT	;YES
	IMULI	B,12		;MULTIPLY HIGH D.P. FRACTION BY 10
	MULI	CC,12		;MULTIPLY LOW D.P. FRACTION BY 10
	ADD	B,CC		;ADD HI PART OF LO PRODUCT INTO RESULT
	MOVE	CC,D		;GET LO PART OF LO PRODUCT
	TLO	CC,(1B0)	;STOP OVERFLOW IF CARRY INTO HI WORD
	ADD	CC,C		;ADD DIGIT INTO FRACTION
	TLZN	CC,(1B0)	;SKIP IF NO CARRY INTO HI WORD
	ADDI	B,1		;PROPOGATE CARRY INTO HI WORD
	JRST	GETNXT		;GET NEXT CHARACTER

MAGIC:	<377777777777-9>/^D10	;LARGEST NUM PRIOR TO MULTIPLY AND ADD

DIGEXP:	IORI	FLG,EXPFL	;SET FLAG TO SAY WE'VE SEEN EXPONENT
	CAILE	XP,^D100	;SIMPLE TEST FOR LARGNESS
	JRST	GETNXT		;THROW DIGIT AWAY
	IMULI	XP,12		;MULTIPLY BY TEN
	ADD	XP,C		;ADD IN NEXT DIGIT
	JRST	GETNXT		;GET NEXT CHAR


;VERTICAL STATES (LAST 3 BITS) ARE:
;0	NOTHING USEFUL SEEN (BLANKS TABS )
;1	SIGNED DIGITS SEEN
;2	DECIMAL POINT AND DIGITS SEEN
;3	D OR E SEEN
;4	EXPONENT SEEN

;HORIZONTAL STATES (FIRST 6 BITS) ARE:
;	 ? ,CR , . ,0-9,   ,D E, + , - ,
NXTSTA:	BYTE (9)
	130,010,022,031,050,130,051,061,
	000,011,022,031,041,053,000,000,
	000,012,120,102,042,053,000,000,
	000,013,120,114,043,000,054,074,
	000,014,120,114,044,000,120,120
	

BLNKIN:	JRST	ENDF0

ILLCH: DELCK:
	JRST	ENDF0

ENDF0:	TRNE	FLG,DOTFL	;HAS DECIMAL POINT BEEN INPUT?
	JRST	ENDF2		;YES
ENDF2:	TRNE	FLG,MINEXP	;WAS D OR E EXPONENT NEGATIVE?
	MOVNS	XP		;YES, SO NEGATE IT
	ADD	X,XP		;ADD EXPONENT FROM D OR E
	MOVEI	BXP,306		;INIT BINARY EXPON FOR D.P. INTEGER
	JUMPN	B,NORM1		;XFER IF AT LEAST ONE 1 IN HIGH HALF
	EXCH	B,CC		;HIGH HALF ZERO, MOVE LOW HALF TO HIGH,
				;AND CLEAR LOW HALF
	SUBI	BXP,^D35	;AND ADJUST EXPONENT FOR 35 SHIFTS
NORM1:	MOVE	A,B		;GET D.P. HIGH HALF INTO A
	JFFO	A,NORM2		;ANY ONES NOW?
	JRST	[SETZB A,B	;NO, RESULT IS ZERO
		TRNE  FLG,DIGSN ;ANY DIGITS SEEN?
		JRST  RETURN	;YES, RETURN OK
		JRST  RETRN1]	;NO, RETURN ERROR
NORM2:	EXCH	B,CC		;YES, GET D.P. LOW HALF INTO B, AND
				;PUT SHIFT COUNT INTO CC
	ASHC	A,-1(CC)	;NORMALIZE D.P. INTEGER WITH BIN POINT
				;BETWEEN BITS 0 AND 1 IN HIGH WORD
	SUBI	BXP,-1(CC)	;AND ADJUST EXPON TO ALLOW FOR SHIFTING
	JUMPE	X,ENDF6		;IF DECIMAL EXP=0, NO MUL BY 10 NEEDED
ENDF3:	MOVM	D,X		;GET MAGNITUDE OF DECIMAL EXPONENT
	CAILE	D,PTLEN$	;BETWEEN 0 AND MAX. TABLE ENTRY?
	MOVEI	D,PTLEN$	;NO, MAKE IT SO
	SKIPGE	X		;AND RESTORE CORRECT SIGN
	MOVNS	D
	SUB	X,D		;LEAVE ANY EXCESS EXPONENT IN X
	JUMPDP	DPMUL		;DOUBLE PRECISION?
SPMUL:	MUL	A,HITEN$(D)	;NO, MULTIPLY BY POWER OF TEN
	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:	IDIVI	D,4		;CONVERT DEC EXP TO BINARY EXPONENT
	LDB	D,EXTAB.(D+1)	;BY TABLE LOOKUP
	ADDI	BXP,-200(D)	;ADJUST BINARY EXPONET (LESS EXCESS 200)
	JUMPN	X,ENDF3		;ANY MORE DECIMAL EXPONENT LEFT?
ENDF6:	TLO	A,(1B0)		;NO, START ROUNDING (ALLOW FOR OVERFLOW)
	JUMPDP	DPRND		;DOUBLE PRECISION?
SPRND:	ADDI	A,200		;NO, ROUND IN HIGH WORD
	TRZ	A,377		;GET RID OF USELESS (UNUSED) BITS
	MOVEI	B,0		; DITTO
	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:	TRNE	BXP,777400	;IS BINARY EXPONENT TOO LARGE
	JRST	BADEXP		;YES, RETURN ZERO OR INFINITY
	ASHC	A,-8		;NO, LEAVE ROOM FOR EXPONENT
	DPB	BXP,[POINT 9,A,8] ;INSERT EXPONENT INTO HI WORD
RETURN:	AOS	(P)		;OK RETURN
RETRN1:	TRNE	FLG,MINFR	;RESULT NEGATIVE?
	DMOVN	A,A		;YES, SO NEGATE RESULT
	POPJ	P,		;RETURN TO CALLER

BADEXP:	HRLOI	A,377777	;SET NUMBER TO LARGEST POSSIBLE
	HRLOI	B,377777
	TRNN	BXP,1B18	;IF EXPONENT IS NEGATIVE
	JRST	RETRN1		;NO, RETURN
ILLFST:
ZERO:	SETZB	A,B		;SET TO ZERO
	JRST	RETRN1

	POINT 9,EXP10$-1(D),17
	POINT 9,EXP10$-1(D),26
	POINT 9,EXP10$-1(D),35
EXTAB.:	POINT 9,EXP10$(D),8
	POINT 9,EXP10$(D),17
	POINT 9,EXP10$(D),26
	POINT 9,EXP10$(D),35

REPEAT 0,<			;COBOL DOESN'T KNOW DOUBLE PRECISION FLOAT
;HERE FOR DOUBLE PRECISION MULTIPLY, ROUNDING 

DPMUL:	MUL	B,HITEN$(D)	;LO FRAC TIMES HI POWER OF TEN(RESULT IN B,C)
	MOVE	P1,B		;GET HI PART OF PREVIOUS PRODUCT OUT OF WAY
	MOVE	B,A		;COPY HI PART OF FRACTION
	MUL	B,LOTEN$(D)	;HI FRAC TIMES LO POWER OF TEN
	TLO	P1,(1B0)
	ADD	P1,B		;SUM OF HI PARTS OF CROSS PRODUCTS TO AC T
	MUL	A,HITEN$(D)	;HI FRACTION TIMES HI POWER OF TEN
	TLON	P1,(1B0)	;DID CARRY OCCUR?  ALLOW FOR NEXT CARRY
	ADDI	A,1		;CARRY FROM ADDING CROSS PRODUCTS
	ADD	B,P1		;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
	JRST	ENDF5		;GO NORMALIZE RESULT

DPRND:	TLO	B,(1B0)		;START ROUNDING (ALLOW FOR CARRYS)
	ADDI	B,200 		;LOW WORD ROUNDING
	TLZN	B,(1B0)		;DID CARRY PROPOGATE TO SIGN?
	AOJA	A,ENDF7		;YES, ADD CARRY INTO HIGH WORD
	JRST	ENDF7		;AND GO RENORMALIZE IF NECESSARY
>;END REPEAT 0
REPEAT 1,<
DPRND: DPMUL:	HALT
>
	END			;;;