TITLE 'ACQCONST-B00,08/21/73,DWG702985' SYSTEM SIG7F CSECT 1 PCC 0 CONTROL CARDS NOT PRINTED. ACQCONS@ RES 0 ORIGIN OF CONSTANT ACQ. MODULE. * * REF'S AND DEF'S * DEF ACQCONS@ = START OF ACQCONST MODULE. DEF ACQCONST ACQUIRE CONSTANT -- ENTRY PT. SPACE 3 REFS TO PROCEDURE: * REFS TO PROCEDURE: REF ACQCC ACQ. CURRENT CHAR AND ITS CODE. REF ACQCODE ACQ. CURRENT CHAR'S CODE. SPACE 2 * REFS TO CONTEXT: REF CONSTDT DBLWD TEMP. REF CONSTDTX EXTRA DBLWD TEMP. REF CONSTAD DBLWD TEMP -- 1ST WD IS ALWAYS ZERO. REF CONSTBUF BUFFER TO HOLD CONSTS (FOR VECTORS). REF CONSTTYP TYPE-OF-CONSTANT INDICATOR: * 0 OR 1 = LOGICAL. * > 1 = INTEGER. * - 1 = REAL. REF NSPILLED TEMP FOR NO.OF DIGITS SPILLED. * REFS TO CONSTANTS REF ZEROZERO 0,0 REF F0F9 '0','9' REF X4E1 X'4E100000', 0 REF BITPOS 32-WD BIT-TBL (BITPOS-K CONTAINS A * WD HAVING A 1 ONLY IN BIT POS. K). * * EQU'S RELATED TO CONTEXT * CONSTTMP EQU NSPILLED TEMP WD SPACE * * STANDARD EQU'S * REGISTERS R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 * * OTHER EQU'S * NEGSIGN EQU X'72' INTERNAL (EBCDIC) NEGATIVE SIGN. FNEG EQU 2 FLAGS NEGATIVE REAL NOS. ENEG EQU 1 FLAGS REAL NOS. WITH NEG. EXPONENTS. * * DOUBLEWORD CONSTANTS * BOUND 8 PTORE DATA '.','E' PTORNEG DATA '.',NEGSIGN M100P100 DATA -100,100 1TENTH DATA X'0CCCCCCC',X'CCCCCCCE' ANY NO. LESS THAN THIS CAN BE * MULTIPLIED BY 10 WITHOUT OVERFLOW. SPACE X4E DATA X'4E000000',0 * * WORD CONSTANTS * X488 DATA X'48800000' EXPON48 DATA X'48000000' PAGE * * POWERS OF TEN * * THE POWERS OF TEN USED FOR SCALING ARE DEFINED IN TABLES BELOW. * EACH POWER HAS THREE NUMBERS ASSOCIATED: (P) POWER (SEE TENP), * (F) FRACTION (SEE TENF), AND (E) BINARY EXPONENT (SEE TENE). * THEY SATISFY: * 1 <= P <= 13 * 10**P = F*(2**E) * .5 <= F < 1.0 * * CURRENTLY USED P-VALUES ARE: 1, 4, AND 13. * TENP EQU %-1 DATA 1,4,13 NTENS EQU %-TENP-1 * TENE EQU %-1 DATA 4,14,44 * TENF EQU %-1 DATA X'50000000' = 10 * 2**(-4) DATA X'4E200000' = 10**4 * 2**(-14) DATA X'48C27395' = 10**13 * 2**(-44) PAGE ************************************************************************ * * * ACQCONST -- SUBROUTINE TO ACQUIRE CONSTANTS (VECTOR OR SCALAR) THAT * * ARE IN INTERNAL FORM, PRODUCING THE REAL OR INTEGER EQUIVS. * * IN THE CONSTANT BUFFER -- CONSTBUF. THE TYPE OF THE CONSTANT * * IS PRODUCED IN -- CONSTTYP: * * 0 OR 1 INDICATES LOGICAL DOMAIN, * * > 1 INDICATES INTEGER DOMAIN, * * AND -1 INDICATES REAL DOMAIN. * * * * ACQCONST IS ENTERED WHEN (IN REASONABLE CONTEXT) A DIGIT, * * DECIMAL POINT, OR NEGATIVE SIGN IS PICKED UP. IT IS POSSIBLE * * THAT, DUE TO SYNTAX ERROR, ACQCONST WILL NOT ENCOUNTER A * * NUMBER; HOWEVER, ACQCONST DOES NOT GENERATE ANY ERROR DIAGS. * * IN FACT, THE ONLY ERROR IT RECOGNIZES IS AN OVERFLOW -- WHICH * * RESULTS IN A UNIQUE EXIT. UNDERFLOW PRODUCES A ZERO (IN THE * * APPROPRIATE DOMAIN). * * * * ACQCONST ATTEMPTS TO OPTIMIZE THE HANDLING OF INTEGER DOMAIN * * CONSTANTS BY UTILIZING SOMEWHAT REDUNDANT PROCEDURE. IT ALSO * * ATTEMPTS TO STAY IN INTEGER DOMAIN AS LONG AS POSSIBLE, FOR * * EXAMPLE ' 1.23E5 ' WILL BE TREATED AS AN INTEGER UNLESS THE * * CONSTANT ALREADY HAS CONTAINED PRIOR REAL NUMBERS. * * * * REGS: R4 -- LINK; EXIT (EFFECTIVELY) IS VIA * * 0,R4 IF OVERFLOW OR * * 1,R4 IF NO OVERFLOW (ACTUALLY, THE * * NORMAL EXIT IS MADE BY LINKING* * THRU 'ACQCC' OR 'ACQCODE' IN * * ORDER TO INSURE THAT THE CHAR * * AND CODE (NON-BLANK) THAT * * TERMINATES THE CONSTANT IS * * READY FOR FURTHER CODESTRING * * WORK. * * R1 -- (ENTRY) PTS AT DIGIT, DEC.PT, OR NEG.SIGN. * * (EXIT) PTS AT TERMINATION CHAR (POSSIBLY SAME * * AS AT ENTRY IF SYNTAX ERROR). * * R2 -- (ENTRY) CONTAINS DIGIT, DEC.PT, OR NEG.SIGN. * * (EXIT) CONTAINS TERMINATION CHAR (NON-BLANK). * * R3 -- (EXIT) CONTAINS CODE FOR TERMINATION CHAR. * * R6 -- (EXIT) CONTAINS THE NO.OF NUMBERS IN THE * * CONSTANT (ZERO IF SYNTAX ERROR). * * R5 THRU R14 ARE VOLATILE. * * * ACQCONST AI,R4 1 ASSUME NO-OVERFLOW EXIT. LI,R6 0 R6 = NO.OF NOS. IN CONSTANT. STW,R6 CONSTTYP TYPE 0 -- START AS LOGICAL CONSTANT. BAL,R5 NSET DO SET-UPS FOR NUMBER. ISET LI,R9 0 R9 = INTEGER ACCUMULATOR. AI,R2 -'0' DOES MAGNITUDE START WITH DIGIT... BGEZ IDIG1 YES, 1ST DIGIT. IPT LI,R5 RPT NO, DEC.PT. IE LI,R8 0 B TRYREAL IOK AI,R2 -'0' STRIP OFF HI-ORDER DIGIT OF EBCDIC. IDIG1 STW,R2 CONSTAD+1 (INDICATES PRESENCE OF A DIGIT). AW,R9 CONSTAD+1 ACCUMULATE IT. BNOV INXT LI,R5 PNXT OH-OH, INTEGER REACHES R9'S SIGN-BIT B TOOBIG IDIG MI,R8 10 PREPARE FOR NEXT ACCUMULATE. BNOV IOK LI,R5 PM OH-OH, INTEGER TOO BIG. TOOBIG LI,R11 0 PREPARE TO ENTER THE 'PACK' ROUTINE, STW,R11 NSPILLED LI,R14 RPTQ LIKE STARTING A REAL NO. TRYREAL SLD,R8 1 REAL NO. IS SHIFTED 1. LI,R3 0 R3 = DECIMAL EXPONENT. B 0,R5 INXT AI,R1 1 GET NEXT CHAR. LB,R2 0,R1 CLM,R2 F0F9 CK FOR DIGIT. BCR,9 IDIG YES. CLM,R2 PTORE NO, CK FOR DEC.PT OR AN E. BCS,9 IZ NO -- END INTEGER. BCR,2 IPT DEC.PT. BCS,4 IZ NO -- END INTEGER. LI,R5 RE E B IE RICK LW,R7 CONSTTYP ARE WE IN INTEGER DOMAIN, SO FAR... BLZ RZ NO -- REAL. CW,R8 X488 YES, IS REAL VALUE TO BIG FOR INTG BGE REALSW YEP, SWITCH TO REAL DOMAIN. STD,R8 CONSTDTX NOPE, SAVE OUR REAL VALUE. FAL,R8 X4E CK FOR LOSS OF FRACTION. CD,R8 CONSTDTX BNE REALSW8 YES, SWITCH TO REAL DOMAIN. FAL,R8 X4E1 NO, GET INTEGER VALUE IN R9. IZ STS,R9 CONSTTYP (THIS GIVES INTG VS LOGL INDICATION) AI,R10 -FNEG CK FOR NEGATIVE NO. BLZ ISTORE NO, POSITIVE. LCW,R9 R9 YES, NEGATE. STS,R1 CONSTTYP INSURE TYPE=INTEGER, NOT LOGICAL. ISTORE STW,R9 CONSTBUF,R6 STORE THE INTEGER. LI,R5 ISET EXIT 'FINQ' TO ISET IF NO. SEEMS UP. FINQ XW,R1 CONSTAD+1 SAVE R1, TEST FOR NO DIGITS ACCUM. CI,R1 18 (R1<19 MEANS DIGIT OCCURRED). BG ACQCC -EXIT- NO, R1 PTS AT FALSE-NO.-START; REACQ LW,R1 CONSTAD+1 OK, RESTORE R1. AI,R6 1 WE HAVE 1 MORE NO. IN THE CONSTANT. CI,R2 ' ' DID WE END ON A BLANK... BE BLNKSKIP YES, SKIP IT. CLM,R2 PTORNEG NO, CK FOR DEC.PT OR NEG.SIGN... BCS,9 NSET NOPE, OK. BCR,2 DBLNUM DEC.PT (UNEXPECTED). BCS,4 NSET NOPE, OK. * NEG.SIGN (UNEXPECTED). DBLNUM LI,R6 0 SYNTAX ERROR INDICATION. B ACQCODE -EXIT- ACQ CHAR'S CODE. BLNKQ CI,R2 ' ' SKIP BLANKS. BNE NSET BLNKSKIP AI,R1 1 LB,R2 0,R1 B BLNKQ NSET STW,R1 CONSTAD+1 (>19) SAVE CURR.CHAR LOC IN CASE FALSE-ST. LI,R10 0 CLEAR NEG-FLAGS FOR NO. AND EXPON. CLM,R2 F0F9 CK FOR DIGIT. BCR,9 0,R5 YES, WORK THAT NO. CLM,R2 PTORNEG NO, CK FOR DEC.PT OR NEG.SIGN. BCS,9 ACQCODE -EXIT- NEITHER; ACQ CHAR'S CODE. BCR,2 0,R5 DEC.PT (COULD BE FALSE-START). BCS,4 ACQCODE -EXIT- NEITHER. LI,R10 FNEG NEG-SIGN -- SET NEG-FLAG FOR NO. -- AI,R1 1 (COULD BE FALSE-START). LB,R2 0,R1 GET NEXT CHAR. CLM,R2 F0F9 CK FOR DIGIT AFTER NEG-SIGN... BCR,9 0,R5 YES, WORK THAT NO. CI,R2 '.' NO, CK FOR DEC.PT... BE 0,R5 YEP (COULD BE FALSE-START). BDR,R1 ACQCC -EXIT- REACQ NEG-SIGN FOR FALSE-START. B 0,R5 REALSW8 LD,R8 CONSTDTX RESTORE REAL VALUE. REALSW LW,R7 R6 GET NO.OF EARLIER INTEGERS... BEZ REALD NONE, NO NEED TO CONVERT. REALC LW,R12 CONSTBUF-1,R7 SOME; IN REVERSE ORDER, CONVERT LI,R13 0 OLD INTEGERS TO REALS. SAD,R12 -8 EOR,R12 EXPON48 FAL,R12 ZEROZERO STD,R12 CONSTBUF-2,R7 BDR,R7 REALC REALD LI,R7 -1 SET REAL DOMAIN INDICATION. STW,R7 CONSTTYP RZ AI,R10 -FNEG CK FOR NEGATIVE NO. BLZ RSTORE NO, POSITIVE. LCD,R8 R8 YES, NEGATE. RSTORE STD,R8 CONSTBUF,R6 STORE THE REAL NO. BAL,R5 FINQ MAKE FINALIZATION QUERIES. LD,R8 ZEROZERO CONTINUE -- CLEAR REAL ACCUMULATOR LI,R14 RPTQ EXIT FROM 'PACK' TO 'RPTQ'. PACK LI,R11 0 R11 = NO.OF DIGITS PACKED. STW,R11 NSPILLED (CLEAR NO.OF DIGITS SPILLED, TOO). PDQ CLM,R2 F0F9 DIGIT QUERY... BCR,9 PDIG YES, DIGIT. B *R14 NO, EXIT FROM PACK. PDIG CD,R8 1TENTH SEE IF ACCUM. WOULD OVERFLOW... BL POK NO. MTW,1 NSPILLED YES, COUNT THAT DIGIT POSITION, B PNXT BUT DON'T ACCUMULATE ANY MORE. POK AI,R11 1 COUNT THE DIGIT TO BE PACKED. STD,R8 CONSTDT MULTIPLY CURRENT ACCUMULATION SLD,R8 2 BY 10 (IT WAS GUARANTEED THAT AD,R8 CONSTDT THIS WILL REACH NO FURTHER THAN SLD,R8 1 BIT POS. 1 OF R8). PM AI,R2 -'0' (POST-MULT) STRIP EBCDIC CODE OFF. SLS,R2 1 NOTE--INSURE ACCUM. BIT POS. 63 NOT USED; * THUS PACK PRODUCES A 62-BIT NO., * AND BITS 0 AND 63 ARE ZERO. (THE * REASON IS TO ALLOW ACCUM TO BE * SPLIT INTO 2 31-BIT WDS LATER; * OTHERWISE, SIGNS COULD CAUSE * CONFUSION). STW,R2 CONSTAD+1 (CONSTAD+0 IS ALWAYS ZERO). AD,R8 CONSTAD ACCUMULATE. PNXT AI,R1 1 LB,R2 0,R1 GET NEXT CHAR. B PDQ RPTQ LW,R3 NSPILLED R3 = DECIMAL EXPONENT (DE). CI,R2 '.' DECIMAL PT. QUERY... BNE REQ NO, TRY FOR E. RPT AI,R1 1 GET CHAR AFTER DEC PT. LB,R2 0,R1 BAL,R14 PACK ACCUMULATE FRACTION DIGITS, IF ANY. SW,R3 R11 DECR DE BY THAT MANY DIGITS. REQ CI,R2 'E' E QUERY... BNE REAL NO, PROCESS REAL NO. RE XW,R1 CONSTAD+1 SAVE R1, TEST FOR NO DIGITS YET CI,R1 18 (R1 < 19 MEANS DIGIT OCCURRED)... BG ACQCC -EXIT- NO, R1 PTS AT FALSE-START, REACQ. XW,R1 CONSTAD+1 OK, RE-EXCHANGE. AI,R1 1 GET NEXT CHAR. LB,R2 0,R1 CLM,R2 F0F9 DIGIT... BCR,9 RED YES, E FOLLOWED BY DIGIT. CI,R2 NEGSIGN NO, NEGATIVE SIGN... BE RENQ YES. LI,R2 'E' NO, RESTORE THE E, PT TO IT, AND BDR,R1 REAL PROCESS REAL NO. RENQ AI,R10 ENEG SET EXPONENT-NEGATIVE FLAG. AI,R1 1 GET NEXT CHAR. LB,R2 0,R1 CLM,R2 F0F9 DIGIT... BCR,9 RED YES. LI,R2 NEGSIGN NO, RESTORE THE NEG.SIGN, BACK UP BDR,R1 REAL RED STD,R8 CONSTDTX SAVE ACCUM. 'FRACTION' LD,R8 ZEROZERO CLEAR TO ACCUM. EXPONENT. BAL,R14 PACK ACCUM. IT. OR,R8 NSPILLED CK FOR RIDICULOUSLY BIG EXPONENT... BEZ REOK NO, OK SO FAR CI,R10 ENEG YES, CK O'FLO VS U'FLO. BANZ UFLO B -1,R4 -EXIT- OVERFLOW * REOK SLS,R9 -1 ACCUM. EXP. WAS SHIFTED 1. CI,R10 ENEG CK EXPONENT SIGN... BAZ RPE POSITIVE. SW,R3 R9 NEGATIVE, DECR. DE. B ROUT RPE AW,R3 R9 INCR. DE. ROUT BNOV RGO GO UNLESS RESULT RIDICULOUSLY BIG... BLZ -1,R4 -EXIT- OVERFLOW (SIGN REVERSAL). UFLO LD,R8 ZEROZERO UNDERFLOW -- ASSUME ZERO REAL NO. B RICK CK FOR REALLY INTEGER RGO LD,R8 CONSTDTX RESTORE ACCUM. FRACTION. REAL CD,R8 ZEROZERO TEST FOR ZERO... BEZ RICK YES, CK FOR REALLY INTEGER. CLM,R3 M100P100 NO, IS DE REASONABLE... BCR,9 BINORM OK -- DO BINARY NORMALIZATION. HIORLO BG -1,R4 -EXIT- OVERFLOW LD,R8 ZEROZERO UNDERFLOW -- ASSUME ZERO REAL NO. B RICK CK FOR REALLY INTEGER. BINORM AI,R8 0 IF FRACTION'S HI-HALF IS 0, BEZ RNORM USE RIGHT-HAND NORMALIZATION. LI,R5 63 R5= BIN.EXP (BE) -- PRESET & BIASED. LLOOP SLD,R8 1 LEFT SHIFT, AI,R5 -1 DECR. BE, AI,R8 0 TEST FRACTION'S SIGN... BGZ LLOOP + -- SHIFT AGAIN. B CLRBIT0 - -- CLEAR SIGN POS. AND GO. RNORM LI,R5 -1 R5= BIN.EXP (BE) -- PRESET & BIASED. RLOOP SCD,R8 -1 ROTATE RIGHT, AI,R5 1 INCR. BE, AI,R9 0 TEST LO-HALF EMPTIED OF 1'S... BNEZ RLOOP NO, RE-CYCLE. CLRBIT0 SLD,R8 -1 MOVE OVER TO CLEAR SIGN BIT. LI,R7 NTENS R7 = 'TEN-POWER' NO. AI,R3 0 TEST DECIMAL EXPONENT (DE)... BLEZ DENORZ NEGATIVE OR ZERO. LI,R14 0 POSITIVE, CLEAR TOP WORD OF THE STW,R14 CONSTDT DBLWD TEMP. DEPOS SW,R3 TENP,R7 TRY SCALING DOWN DE... BLZ DEPR TOO FAR, RECOVER IT. STW,R8 CONSTTMP OK, SAVE HI HALF OF FRACTION. SLS,R9 -1 GET MAGNITUDE OF LO HALF. MW,R8 TENF,R7 MULT BY A PURE POWER OF TEN. SLD,R8 1 PREPARE TO ADD IN THE LO HALF'S STW,R8 CONSTDT+1 PRODUCT (CONSTDT+0 IS ZERO). LW,R9 CONSTTMP RECOVER HI HALF FOR ITS MW,R8 TENF,R7 MULTIPLICATION. AD,R8 CONSTDT ADD IN THE LO HALF'S PRODUCT. SLD,R8 1 CW,R8 BITPOS-1 POST-NORMALIZE. BANZ DEPBE SLD,R8 1 AI,R5 -1 DEPBE AW,R5 TENE,R7 ADJ BINARY EXPONENT. B DEPOS DEPR AW,R3 TENP,R7 RECOVER DE. BEZ DEZERO OK, IT IS ZEROED. BDR,R7 DEPOS TRY ANOTHER PURE POWER OF TEN. * NEVER FALLS THRU. DENORZ BEZ DEZERO OK, DE IS ZEROED. DENEG AW,R3 TENP,R7 TRY SCALING UP DE... BGZ DENR TOO FAR, RECOVER IT. CW,R8 TENF,R7 POSITION DIVIDEND TO GET NORM. QUOT. BL DENQ SLD,R8 -1 AI,R5 1 DENQ SLD,R8 -1 DW,R8 TENF,R7 HI-ORDER QUOTIENT. STW,R9 CONSTTMP SAVE IT. LW,R9 TENF,R7 NEW DIVIDEND = HI-ORDER REMAINDER SLD,R8 -1 + HALF OF DIVISOR (FOR ROUNDING). DW,R8 TENF,R7 LO-ORDER QUOTIENT. SLS,R9 1 PACK IT TOGETHER LW,R8 CONSTTMP WITH THE HI-ORDER QUOTIENT. SW,R5 TENE,R7 ADJ BINARY EXPONENT. B DENEG DENR SW,R3 TENP,R7 RECOVER DE. BEZ DEZERO OK, IT IS ZEROED. BDR,R7 DENEG TRY ANOTHER PURE POWER OF TEN. * NEVER FALLS THRU. DEZERO AI,R5 1+4*64 BIAS BINARY EXPON (APPX HEX EXPON). LI,R7 3 CK ITS 2 LOW BITS. AND,R7 R5 CALC SHIFT NECESSARY TO NORMALIZE CI,R7 1 HEXADECIMALLY. BLE NSHIFT AI,R7 -4 NSHIFT SLD,R8 -8,R7 POSITION FRACTION. SW,R5 R7 CORRECT BINARY EXPONENT. SAS,R5 -2 CHANGE TO (EXCESS-64) HEX EXPONENT. STB,R5 R8 SET CHARACTERISTIC OF REAL NO. CI,R5 X'FFF80' WAS IT IN RANGE (0 - 127)... BAZ RICK YES -- CK FOR REALLY INTEGER. AI,R5 0 NO, TEST IT FOR AN B HIORLO O'FLO VS U'FLO DETERMINATION. PAGE ************************************************************************ SPACE 2 Z SET %-ACQCONS@ SIZE OF ACQCONST IN HEX. SPACE Z SET Z+Z/10*6+Z/100*96+Z/1000*1536 SIZE IN DECIMAL. SPACE 2 END