Trailing-Edge
-
PDP-10 Archives
-
BB-H506D-SM_1983
-
cobol/source/accept.mac
There are 7 other files named accept.mac in the archive. Click here to see a list.
; UPD ID= 3470 on 3/26/81 at 9:51 AM by NIXON
TITLE ACCEPT FOR LIBOL JEF/DMN
SEARCH LBLPRM ;GET PARAMETERS
IFN TOPS20,< SEARCH MACSYM,MONSYM>
IFE TOPS20,< SEARCH MACTEN,UUOSYM>
IFN LSTATS,< SEARCH METUNV ;LSTATS METER DEFINITIONS>
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
; OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1973, 1981, BY DIGITAL EQUIPMENT CORPORATION
;[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
;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: 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
AOJN 1,GETEOL ;ANSWER AND
AOJA 0,GETEOL ;EXIT
; 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 ;;;