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