; ; ;COPYRIGHT (C) 1975,1981,1982 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 CODE GENERATION ROUTINES PART 2 ; WRITTEN BY H. VAN ZOEREN, C.M.U. ; EDITED BY R. M. DE MORGAN and Andrew J. Skinner HISEG SEARCH ALGPRM,ALGMAC ; SEARCH PARAMETER FILES MODULE MFUN; $PLEVEL=2; BEGIN EXPROC CGBIN EXPROC CLOSE EXPROC EMITCODE EXPROC ERRLEX EXPROC FAIL EXPROC GLOAD EXPROC IPLUNK EXPROC LOAD EXPROC MERGEPORTIONS EXPROC PLUNK EXPROC REOPEN EXPROC REVORDER EXPROC TOCT1 EXPROC TOCT2 EXPROC UNSTACK INTERN CTIR,CTILR,CTRI,CTRLR,CTLRI,CTLRR INTERN LFADC,LFSBC,LFMPC,LFDVC INTERN POWC1,POWC2,POWC3 EXTERN PRASE,ZABS,ZBOOL,ZENTIER,ZINT,ZSIGN EXTERN OPABS,OPENT1,OPENT2,OPENT3,OPJSPX,OPMVMS,OPUMIN EXTERN OPPSJP,OPSGN1,OPSGN2,OPSGN3,OPSETO EXTERN OPADDB,OPAOS,OPSOS,OPMVSM EXTERN OPJMPE,OPJMPG,OPJRST,OPMVLP EXTERN OPCONC,OPCONV,OPMOVE,OPABS1,OPLNEG EXTERN OPENT4,OPENT5 EXTERN SRCEMC,TARGMC ; SOURCE/TARGET FLAGS SUBTTL COMPILE-TIME TYPE-CONVERSION ROUTINES ; CTIR INTEGER TO REAL ; CTILR INTEGER TO LONG REAL ; CTRI REAL TO INTEGER ; CTRLR REAL TO LONG REAL ; CTLRI LONG REAL TO INTEGER ; CTLRR LONG REAL TO REAL ; ON ENTRY, THE ARGUMENT IS IN A0 OR A0,A1 ; THE LINK IS ON THE STACK ; ON EXIT, THE RESULT IS IN A0 OR A0,A1 CTIR: SKIPN SRCEMC ; IS IT A KI10 ? JRST CTIR1 ; NO FLTR A0,A0 POPJ SP, CTIR1: ; THIS WAY ON A KA IDIVI A0,400000 ; SEPARATE HIGH AND LOW HALVES JUMPE A0,.+2 ; ONLY 18 BITS? TLC A0,254000 ; NO -- SET UP HIGH HALF EXPONENT TLC A1,233000 ; SET UP LOW HALF EXPONENT FADR A0,A1 ; AND ADD BITS TOGETHER POPJ SP, CTILR: ;[172] SKIPE SRCEMC ;[172] ARE WE A KA PROCESSOR? JRST CTILR1 ;[172] NO, SKIP KA CODE IDIVI A0,400000 ; SEPARATE HIGH AND LOW HALVES JUMPE A0,.+2 ; ONLY 18 BITS? TLC A0,254000 ; NO -- SET UP HIGH HALF EXPONENT TLC A1,233000 ; SET UP LOW HALF EXPONENT FADL A0,A1 ; AND ADD BITS TOGETHER SKIPN TARGMC ; IF TARGET IS A KA, FINISH POPJ SP, TLZ A1,777000 ; IF KI10 TARGET, WIPE OUT LOW WORD EXPONENT LSH A1,10 ; AND SHIFT UP FRACTION POPJ SP, CTILR1: SETZ A1, ;[172] HERE IF WE ARE A KI OR KL ASHC A0,-8 ;[172] CLEAR SECOND WORD AND SHIFT TLC A0,243000 ;[172] INSERT EXPONENT DFAD A0,[EXP 0,0] ;[172] NORMALIZE SKIPE TARGMC ;[172] IF TARGET MACHINE IS KI OR KL POPJ SP, ;[172] THEN FINISHED, SO RETURN LSH A1,-10 ;[172] TARGET IS KA, SHIFT SECOND MANTISSA SKIPN A1 ;[172] FAKE RESULTS OF A "FADL" INSTRUCTION POPJ SP, ;[172] DONE IF SECOND WORD IS ZERO PUSH SP,A2 ;[172] ELSE GET A REGISTER TO MAKE EXPONENT IN LDB A2,[POINT 8,A0,8] ;[172] GET HIGH-ORDER EXPONENT CAIGE A2,200 ;[172] SKIP IF POSITIVE EXPONENT MOVN A2,A2 ;[172] ELSE MAKE IT POSITIVE ANDI A2,377 ;[172] AND OFF ANY EXTRA BITS THIS CAUSED SUBI A2,^D27 ;[172] SUBTRACT 27 BITS OF HIGH-ORDER MANTISSA SKIPGE A2 ;[172] IF NOTHING LEFT FOR LOW ORDER, SKIPA A1,0 ;[172] THEN FORCE SECOND WORD TO ZERO DPB A2,[POINT 8,A1,8] ;[172] ELSE INSERT SECOND EXPONENT POP SP,A2 ;[172] PUT BORROWED REGISTER BACK POPJ SP, ;[172] AND RETURN (WHEW!) ; Edit(153); Perform rounding correctly. ; CTRI: FAD A0,[ ; [E153] CTRI -- ADD 0.5 exp 0.5] MULI A0,000400 ; SEPARATE EXPONENT AND MANTISSA EXCH A0,A1 TSC A1,A1 ; FIX UP EXPONENT HRREI A1,-243(A1) ; [E130] ADJUST EXPONENT JUMPG A1,.+3 ; [E130] TOO BIG - OVERFLOW ASH A0,(A1) ; [E130] SHIFT MANTISSA TO FORM INTEGER POPJ SP, FAIL(128,SOFT,SYM,INTEGER TOO LARGE) ; [E130] JUMPL A0,.+3 ; [E130] POSITIVE OR NEGATIVE ? HRLOI A0,377777 ; [E130] POSITIVE - SET ALL ONES POPJ SP, ; [E130] MOVSI A0,(1B0) ; [E130] NEGATIVE POPJ SP, ; [E130] CTRLR: MOVEI A1,0 ; ZERO LOW ORDER WORD POPJ SP, CTLRI: SELMCC(CTLRI1,CTLRI2,CTLRI3) ; DECIDE THE MIX DFAD A0,[ EXP 0.5,0.0] GOTO CTLRI4 CTLRI1: MOVE A2,A1 ; STRICTLY KA FADL A0,[0.5] UFA A1,A2 FADL A0,A2 GOTO CTLRI4 CTLRI2: DMOVE A3,[ EXP 0.5,0.0] PUSHJ SP,LRADAI CTLRI4: HLRZ A2,A0 LSH A2,-11 ANDI A2,000377 ; EXTRACT HIGH ORDER EXPONENT TLZ A0,377000 ; AND CLEAR IT OUT JUMPGE A0,.+3 ; NUMBER POSITIVE? TRC A2,000377 ; NO -- COMPLEMENT EXTRACTED EXPONENT TLO A0,377000 ; AND SET ALL ONES SKIPN TARGMC ; ONLY SHIFT FOR A KA TARGET LSH A1,10 ; IT'S FOR KA10,SO SHIFT UP LOW ORDER FRACTION SUBI A2,243 ; ADJUST EXPONENT JUMPG A2,.+3 ; TOO BIG - OVERFLOW EDIT(006); CORRECT SHIFT ASHC A0,10(A2) ; [E006] SHIFT MANTISSA TO INTEGER POPJ SP, FAIL(128,SOFT,SYM,INTEGER TOO LARGE) JUMPL A0,CTLRI5 ; NEG ? HRLOI A0,377777 ; SET LARGEST POSITIVE NUMBER POPJ SP, CTLRI5: MOVSI A0,(400000,,0) ; LARGEST NEGATIVE POPJ SP, CTLRR: SELMCC(CTLRR1,CTLRR2,CTLRR3) ; LONG REAL TO REAL ; KI TARGET AND SOURCE JUMPGE A0,.+3 ; ARGUMENT POSITIVE? DMOVN A0,A0 ; NO - NEGATE IT CTLRRD: TLZA A1,400000 ; AND CLEAR BIT 0 FLAG CTLRRC: TLO A1,400000 ; YES - SET BIT 0 FLAG TLNN A1,200000 ; ROUNDING REQUIRED? JRST CTLRRA ; NO CAMN A0,[ XWD 377777,777777] ; YES - HIGH WORD TOO LARGE? JRST CTLRRA ; YES - FORGET IT ADDI A0,1 ; NO TLO A0,400 ; CARRY CTLRRA: JUMPL A1,.+2 ; EXIT IF POSITIVE MOVN A0,A0 ; OTHERWISE NEGATE POPJ SP, CTLRR1: ; KA TARGET JUMPL A0,.+3 ; NEGATIVE NUMBER? FADR A0,A1 ; NO -- ADD HIGH AND LOW WORDS TOGETHER POPJ SP, DFN A0,A1 ; YES -- NEGATE FADR A0,A1 ; AND ADD HIGH AND LOW WORDS TOGETHER MOVN A0,A0 ; NEGATE RESULT POPJ SP, CTLRR2: ; KI TARGET - KA PROCESSOR JUMPGE A0,CTLRRC ; ONLY A PROBLEM IF -VE SETCM A0,A0 MOVNS A1 TLZ A1,(1B0) JUMPN A1,CTLRRD AOJA A1,CTLRRD SUBTTL LONGREAL COMPILE-TIME ARITHMETIC ; ; THIS CODE SORTS OUT THE TARGET AND SOURCE PROCESSORS ; AND PERFORMS THE BASIC OPERATIONS OF + - * / ; ACCCORDINGLY. ; LFADC: ; ADDITION SELMCC(LRADAA,LRADAI,LRADII) LRADII: DFAD A0,A3 POPJ SP, LFSBC: ; SUBTRACTION SELMCC(LRSBAA,LRSBAI,LRSBII) LRSBII: DFSB A0,A3 POPJ SP, LFMPC: ; MULTIPLICATION SELMCC(LRMPAA,LRMPAI,LRSBII) LRMPII: DFMP A0,A3 POPJ SP, LFDVC: ; DIVISION SELMCC(LRDVAA,LRDVAI,LRDVII) LRDVII: DFDV A0,A3 POPJ SP, SUBTTL LONG REAL ARITHMETIC SUBROUTINES ; ON ENTRY: ; THE LEFT HAND OPERAND IS IN A0,A1 ; THE RIGHT HAND OPERAND IS IN (A3,A4) ; THE LINK IS ON THE STACK ; ON EXIT, THE RESULT IS IN A0,A1 LRADAA: UFA A1,A4 ; ADD LOW ORDER PARTS IN A2 FADL A0,A3 ; ADD HIGH ORDER PARTS IN A0,A1 LFAD1: UFA A1,A2 ; ADD LOW PART OF HIGH SUM TO A2 FADL A0,A2 ; ADD LOW SUM TO HIGH SUM JFOVO LFERR ; ERROR IF UNDER- OR OVERFLOW POPJ SP,0 LRSBAA: DFN A0,A1 ; NEGATE LEFT HAND OPERAND PUSHJ SP,LFADC ; PERFORM A LONG ADD DFN A0,A1 ; AND NEGATE RESULT POPJ SP,0 LRMPAA: MOVE A2,A0 ; COPY HIGH WORD OF LEFT HAND OPERAND FMPR A2,A4 ; FORM ONE CROSS PRODUCT IN A2 FMPR A1,A3 ; FORM OTHER CROSS PRODUCT IN A1 UFA A1,A2 ; ADD CROSS PRODUCTS IN A2 FMPL A0,A3 ; FORM HIGH ORDER PRODUCT IN A0,A1 JRST LFAD1 ; FINISH UP LONG ADD LRDVAA: FDVL A0,A3 ; GET HIGH PART OF QUOTIENT MOVN A2,A0 ; AND NEGATE IT FMPR A2,A4 ; MULTIPLY BY LOW PART OF DIVISOR UFA A1,A2 ; ADD REMAINDER FDVR A2,A3 ; DIVIDE SUM BY HIGH PART OF DIVISOR FADL A0,A2 ; ADD RESULT TO ORIGINAL QUOTIENT JFOVO LFERR ; ERROR IF UNDER- OR OVERFLOW POPJ SP,0 LFERR: FAIL(75,FRIED,SYM,OVERFLOW IN LONG REAL OPERATION ON CONSTANTS); POPJ SP,0 ; ERROR EXIT SUBTTL LONG REAL KI10 ARITHMETIC SIMULATION FOR KA10 ; THESE ROUTINES ADD OR SUBTRACT TWO DOUBLE PRECISION ; NUMBERS. EACH NUMBER IS COMPOSED OF 8 BITS OF EXPONENT ; IN THE HI ORDER WORD WITH THE REMAINING 27 HI ORDER BITS ; AND THE 33 FIRST ARITHMETIC BITS OF THE LO ORDER AS THE ; MANTISSA. THE LAST 2 LO ORDER BITS ARE UNUSED. THE ; ANSWER IS RETURNED IN AC 0-1 AND THE ARGUMENTS ARE IN ; A0-1 AND A3-4 RESPECTIVELY LREXP1: POINT ^D9,A0,^D8 ; EXPONENT FOR ARG1 LREXP2: POINT ^D9,A3,^D8 ; EXPONENT FOR ARG2 SGNA0==1 SGNA3==2 BITNEG==1B18 BIT1==200000 BIT2==100000 BITCRY==1000 BITEST==3400 LRLOW0: 377777777777 DEFINE MAKNEG(A)< SETCM A,A MOVNS A+1 TDNN A+1,LRLOW0 AOS A > LRSBAI: MAKNEG(A3) ; ENTRY FOR SUBTRACT LRADAI: JUMPE A3,.+4 ; ENTRY FOR ADD JUMPN A0,GA ; NEITHER ARG IS ZERO, SO GO ADD MOVE A0,A3 ; A0=0 MEANS ARG2 IS ANSWER MOVE A0+1,A3+1 ; RETURN IT TO EITHER AC OR MEM POPJ SP, GA: PUSH SP,A7 LDB A2,LREXP1 ; ARG1 EXP AND SIGN LDB A5,LREXP2 ; ARG2 EXP AND SIGN SKIPG A0 ; MAKE EXPS + ANDCAI A2,777 ; ... SKIPG A3 ; ... ANDCAI A5,777 ; ... MOVE A6,A5 ; GET EXP DIFFERENCE SUB A6,A2 ; ... SKIPLE A6 ; SAVE HIGHER EXP AOS A2,A5 ; SAVED IN A2 TLZ A7,SGNA0+SGNA3 ; MARK SIGNS BEFORE SHIFT JUMPGE A0,A0PL ; SKIP HAIR IF A0 + TLO A7,SGNA0 ; MARK SIGN = - MAKNEG A0 A0PL: JUMPGE A3,A3PL ; SKIP HAIR IF A3 = + TLO A7,SGNA3 ; MARK SIGN = - MAKNEG A3 A3PL: TLZ A0,777000 ; REMOVE EXPS TLZ A3,777000 ; ... JUMPLE A6,SHFT2 ; SHIFT ARG2 MOVNS A6 ; SHIFT ARG1 RIGHT ASHC A0,(A6) ; UNNORMALIZE ARG1 CADD: TLNN A7,SGNA0 ; WAS A0 =-? JRST A0WPL ; NO, SKIP RECOMPL TLNE A7,SGNA3 ; IF BOTH WERE NEG,... JRST BOTHN ; DON'T RECOMPL EITHER MAKNEG A0 A0WPL: TLNN A7,SGNA3 ; WAS A3=-? JRST A3WPL ; NO, SKIP RECOMPL MAKNEG A3 A3WPL: TLZ A0,477000 ; SET TESTABLE BITS TLZ A3,477000 ; TURN OTHERS OFF JCRY1 .+1 ; TURN OFF OVFLO FLAG ADD A0+1,A3+1 ; LO ORDER ADD JCRY1 [ AOJA A0,TADD] ; ADD IN HI ORDER CARRY TADD: ADD A0,A3 ; HI ORDER ADD TLNE A0,BIT2 ; IS CARRY BIT TRUE TLC A0,BITCRY ; NO, COMPL. IT TLZN A0,BIT1 ; IS SUM - JRST NORMA ; NO ON FIRST GLANCE TLZE A0,BIT2 ; ... TLNE A0,BITCRY ; ... PUSHJ SP,NEG1 ; SUM=-,GO MAKE IT + NORMA: TRO A2,200000 ; PROTECT AGAINST BORROWS FROM BITNEG TLNN A0,1000 ; SKIP UNNORM IF NOT NEEDED SOSA A2 ; BUT TELL THE EXPONENT ABOUT IT ASHC A0,-1 ; THERE WAS SOMETHING THERE D.MORM: TRO A2,200000 ; PROTECT AGAINST BORROWS FROM BITNEG TLZ A0,777000 ; NO STRAY BITS JUMPN A0,LOOPA+1 ; CHECK FOR ZERO TDNN A0+1,LRLOW0 ; ... JRST 2,@[ XWD 0,RET0] ; RETURN ZERO ANSWER SKIPA ; ENTER NORMALIZE ROUTINE LOOPA: ASHC A0,1 ; 1 BIT NORMALIZE TLNN A0,400 ; IS NORMALIZE DONE? SOJA A2,LOOPA ; IF NOT, SUB1 FROM EXP TRNE A2,BITEST ; DID FP OV/UNDER FLO OCCUR? JRST [ TRNN A2,040000 ; UNDERFLOW? JRST OVTM2 ; NO, OVERFLOW JRST UFLOW] ; YES TRZE A2,BITNEG ; SHOULD ANS BE - PUSHJ SP,NEG2 ; GO MAKE IT SO DPB A2,LREXP1 ; STORE EXP AND SIGN OVTM1: JRST 2,@[OVTA] ; CLEAR AR FLAGS OVTM2: TRZ A2,400 TRZE A2,BITNEG ; SHOULD ANS BE - PUSHJ SP,NEG2 ; GO MAKE IT SO DPB A2,LREXP1 ; STORE EXPONENT AND SIGN JRST 2,@[XWD 440200,OVTA] RET0: SETZB A0,A0+1 ; RETURN ANS=0 OVTA: TLZ A0+1,400000 ; SET LOW SIGN +VE LRKAEX: POP SP,A7 POPJ SP, UFLOW: TRZ A2,400 TRZE A2,BITNEG PUSHJ SP,NEG2 DPB A2,LREXP1 JRST 2,@[XWD 440300,OVTA] SHFT2: ASHC A3,0(A6) ; UNNORMALIZE ARG2 AOJA A2,CADD ; INDICATE UNNORMALIZATION NEG2: ANDCAI A2,777 ; MAKE EXP - NEG1: TRO A2,BITNEG ; SET MARKER FOR - MOVNS A0+1 ; TWOS COMPL SETCMM A0 ; ... TDNN A0+1,LRLOW0 ; ... AOS A0 ; ... JRST LRKAEX ; RESTORE A7 & RETURN BOTHN: TRO A3,BITNEG ; SINCE BOTH WERE NEG, ANS ... JRST A3WPL ; MUST BE NEG ; BASED ON THE FORTRAN ROUTINES IN DPSIM.MAC ; THESE ROUTINES MULTIPLY TWO DOUBLE PRECISION FLOATING ; NUMBERS.THE ARGUMENTS ARE IN A0-1 AND A3-4. LRMPAI: PUSH SP,A7 JUMPE A3,RET0 ; ZERO PRODUCT JUMPL A3,NEG2A ; IF -, PICK UP COMPL NEG2RT: MOVE A7,A0 ; GET ARG1 JUMPE A0,RET0 ; ZERO PRODUCT XOR A7,A0 ; GET ANSWER SIGN JUMPL A0,NEG1A ; IF -, PICK UP ARG1 COMPL NEG1RT: LDB A2,LREXP1 ; GET EXPS LDB A5,LREXP2 ; ... ADDI A2,-200(A5) ; GET PREDICTED EXP (EXCESS 200) ANDI A2,077777 ; MASK EXPONENT TO 15 BITS TLNE A7,400000 ; IF RESULT SHOULD BE NEG, ... TRO A2,BITNEG ; SET INDICATOR HRL A7,A2 ; SALT AWAY PROPOSED EXP TLZ A0,777000 ; REMOVE EXPS TLZ A3,777000 ; ... ASHC A0,5 ; MAKE SEMI-PRODUCTS MORE SIGNIFICANT ASHC A3,5 ; ... MUL A0+1,A3 ; FORM LO ORDER SEMI-PRODS MUL A3+1,A0 ; ... MOVE A5,A0+1 ; PROTECT FROM CREEPING SIGNIFICANCE MUL A0,A3 ; HI ORDER SEMI-PROD JCRY1 .+1 ; CLEAR FLAG ADD A0+1,A5 ; FIRST LO SEMI-PROD JCRY1 [AOJA A0,A1RT] ; ADD IN CARRY A1RT: ADD A0+1,A3+1 ; SECOND LO SEMI-PROD JCRY1 [AOJA A0,A3RT] ; ADD IN CARRY A3RT: TRNE A0+1,2 ; PATCH FOR MORE PRECISION ADDI A0+1,2 ASHC A0,-2 HLRZ A2,A7 ; RECLAIM EXP JRST D.MORM ; GO NORMALIZE AND RETURN NEG2A: SETCM A3,A3 ; TW0S COMPL ARG2 MOVNS A3+1 ; ... TDNN A3+1,LRLOW0 ; ... AOJA A3,NEG2RT ; ... JRST NEG2RT ; ... NEG1A: SETCM A0,A0 ; TWOS COMPL ARG2 MOVNS A0+1 ; ... TDNN A0+1,LRLOW0 ; ... AOJA A0,NEG1RT ; ... JRST NEG1RT ; ... ; THESE ROUTINES FORM THE QUOTIENT OF TWO DOUBLE ; PRECISION FLOATING POINT NUMBERS. THE DIVIDEND ; IS IN A0-1 THE DIVISOR IS IN A3-4. THE QUOTIENT IS RETURNED ; IN A0-1. LRDVAI: PUSH SP,A7 JUMPL A3,NEG2B ; IF -, PICK UP COMPL NEG2RB: MOVE A7,A0 ; GET AT DIVIDEND XOR A7,A0 ; SIGN OF A7= SIGN OF QUOTIENT JUMPL A0,NEG1B ; IF A0=-, PICK UP COMPL NEG1RB: TDNE A0,[777777777] ; IS DIVIDEND ZERO? JRST RET0 TDNN A3,[777777777] ; OR HAS 11TH COMMANDMENT BEEN VIOLATED? JRST 2,@[XWD 440240,RET0] ; SET DIVIDE CHECK, RETURN 0 LDB A2,LREXP1 ; GET EXPS LDB A5,LREXP2 ; ... SUBI A2,-201(A5) ; GET EXP DIFFERENCE ANDI A2,077777 ; MASK RESULTANT EXP TO 15 BITS TLNE A7,400000 ; MARK QUOTIENT SIGN TRO A2,BITNEG ; ... HRL A7,A2 ; SAVE PROPOSED EXP TLZ A0,777000 ; GRONK EXPS ASHC A3,8 ; AND MAKE QUOTIENT TO RIGHT PLACE ARITH: DIV A0,A3 ; FIRST DIVISION MUL A3+1,A0 ; FORM Q1*D SETCA A3+1, ; TWO'S COMPL OF Q1*D TDNN A3+2,LRLOW0 ; ... AOS A3+1 ; ... ADD A0+1,A3+1 ; A0+1 CONTAINS A0+1-Q1*D DIV A0+1,A3 ; SECOND DIVISION HLRZ A3,A7 ; GET EXP JUMPGE A0+1,D.MORM ; GO NORMALIZE IF POSITIVE SOJA A0,D.MORM ; ADJUST BEFORE NORMALIZE IF NEGATIVE NEG2B: SETCM A3,A5 ; TWOS COMPL OF DIVISOR MOVNS A3+1 ; ... TDNN A3+1,LRLOW0 ; ... AOJA A3,NEG2RB ; ... JRST NEG2RB ; ... NEG1B: SETCM A0,A0 ; TWOS COMPL OF DIVIDEND MOVNS A0+1 ; ... TDNN A0+1,LRLOW0 ; ... AOJA A0,NEG1RB ; ... JRST NEG1RB ; ... SUBTTL POWC1 -- INTEGER TO INTEGER EXPONENTIATION ROUTINE ; ON ENTRY: ; THE BASE IS IN A0 ; THE EXPONENT IS IN A2 ; THE LINK IS ON THE STACK ; ON EXIT, THE RESULT (INTEGER OR REAL) IS IN A0 POWC1: JUMPN A0,POWC11 ; BASE = 0? JUMPLE A2,POWCER ; YES. ERROR IF EXPONENT <= 0 POWC10: POPJ SP, ; RESULT = 0 FOR ZERO BASE AND POS. EXP. POWC11: JUMPL A2,POWC13 ; NEG. EXP. YIELDS REAL RECIPROCAL MOVE A1,A0 ; COPY BASE MOVEI A0,1 ; PREPARE FOR MULTIPLICATION JUMPE A2,POWC10 ; IF EXP. = 0 THEN I^0 = 1 POWC12: TRZE A2,000001 ; BIT SET IN EXPONENT? IMUL A0,A1 ; YES -- MULTIPLY JUMPE A2,POWC25 ; EXIT IF FINISHED IMUL A1,A1 ; OTHERWISE SQUARE MULTIPLIER LSH A2,-1 ; SHIFT BIT OUT OF EXPONENT JRST POWC12 ; AND CARRY ON POWC13: PUSHJ SP,CTIR ; CONVERT INTEGER BASE TO REAL JRST POWC22 ; COMPUTE REAL POWER SUBTTL POWC2 -- REAL TO INTEGER EXPONENTIATION ROUTINE ; ON ENTRY: ; THE BASE IS IN A0 ; THE EXPONENT IS IN A2 ; THE LINK IS ON THE STACK ; ON EXIT, THE RESULT IS IN A0 POWC2: JUMPE A0,POWC24 ; BASE = 0? JUMPN A2,POWC21 ; NO. EXPONENT = 0? MOVSI A0,(1.0) ; YES. R^0 = 1.0 POWC20: POPJ SP, ; EXIT POWC21: CAIG A2,0 ; EXPONENT POSITIVE? POWC22: TDZA A3,A3 ; NO. CLEAR POSITIVE FLAG AND SKIP MOVEI A3,1 ; YES. SET POSITIVE FLAG MOVM A2,A2 ; GET MAGNITUDE OF EXPONENT MOVE A1,A0 ; COPY BASE MOVSI A0,(1.0) ; PREPARE FOR "*" (OR "/") POWC23: TRZE A2,000001 ; BIT SET IN EXPONENT? XCT [ FDVR A0,A1 FMPR A0,A1](A3) ; YES -- MULTIPLY/DIVIDE JUMPE A2,POWC25 ; EXIT IF FINISHED FMPR A1,A1 ; OTHERWISE SQUARE MULTIPLIER LSH A2,-1 ; SHIFT BIT OUT OF EXPONENT JRST POWC23 ; AND CARRY ON POWC24: JUMPG A2,POWC20 ; BASE = 0 -- EXIT IF EXPONENT > 0 POWCER: FAIL(76,FRIED,SYM,OVERFLOW OR UNDEFINED RESULT FOR "CONSTANT ^ CONSTANT"); POPJ SP, ; ERROR EXIT POWC25: JFOVO POWCER ; ERROR IF OVERFLOW FLAG ON POPJ SP, ; NORMAL EXIT SUBTTL POWC3 -- LONG REAL TO INTEGER EXPONENTIATION ROUTINE ; ON ENTRY: ; THE BASE IS IN (A0,A1) ; THE EXPONENT IS IN A2 ; THE LINK IS ON THE STACK ; ON EXIT, THE RESULT (TYPE LONG REAL) IS IN A0,A1 POWC3: JUMPN A0,.+3 ; BASE = 0? JUMPLE A2,POWCER ; YES - ERROR IF EXP LEQ 0 POPJ SP, MOVE A3,A0 ; NO -- COPY BASE MOVE A4,A1 MOVSI A0,(1.0) ; INITIALIZE RESULT TO 1.0&&0 MOVEI A1,0 JUMPN A2,POWC31 ; EXPONENT = 0? POPJ SP,0 ; YES -- RESULT = 1.0&&0 POWC31: PUSH SP,A6 ; SAVE REGISTERS PUSH SP,A7 MOVM A7,A2 ; COPY MAGNITUDE OF EXPONENT JUMPG A2,POWC32 ; EXPONENT POSITIVE? TDZA A6,A6 ; NO -- CLEAR POSITIVE FLAG POWC32: MOVEI A6,1 ; YES -- SET POSITIVE FLAG SELMCC(POWL2,POWL3,POWL1) POWL1: TRZE A7,1 ; STRICTLY KI XCT [ DFDV A0,A3 ; IF BIT SET IN EXPT, THEN DIVIDE/MULTIPLY DFMP A0,A3](A6) JUMPE A7,POWLEX ; ELSE EXIT IF FINISHED DFMP A3,A3 ; OTHERWISE SQUARE MULTIPLIER LSH A7,-1 ; SHIFT BIT OUT OF EXPT JRST POWL1 ; AND CONTINUE ; KA TARGET ON KA SOURCE M/C POWL2: TRZE A7,000001 ; BIT SET IN EXPONENT? XCT [ PUSHJ SP,LRDVAA PUSHJ SP,LRMPAA](A6) JUMPE A7,POWLEX ; EXIT IF FINISHED MOVE A5,A3 ; OTHERWISE SQUARE THE MULTIPLIER FMPR A5,A4 ; LONG REAL MULTIPLY FMPR A4,A3 ; (A3,A4) * (A3,A4) UFA A4,A5 FMPL A3,A3 UFA A4,A5 FADL A3,A5 LSH A7,-1 ; SHIFT BIT OUT OF EXPONENT JRST POWL2 ; AND CARRY ON ; KI SIMULATION ON KA M/C POWL3: TRZE A7,1 ; BIT SET IN EXPONENT ? XCT [ PUSHJ SP,LRDVAI PUSHJ SP,LRMPAI](A6) ; YES - DO MULTIPLY/DIVIDE JUMPE A7,POWLEX ; FINISHED ? PUSH SP,A0 ; SAVE A0 & A1, BECAUSE PUSH SP,A1 ; SIMULATION ROUTINES USE THEM MOVE A0,A3 MOVE A0+1,A3+1 PUSHJ SP,LRMPAI ; SQUARE THE EXPONENT - ANS IN A0,A1 MOVE A3,A0 MOVE A3+1,A0+1 ; GET IT TO RIGHT PLACE POP SP,A0+1 POP SP,A0 LSH A7,-1 ; SHIFT BIT OUT OF EXPONENT JRST POWL3 POWLEX: POP SP,A7 ; RESTORE REGISTERS POP SP,A6 JFOVO POWCER ; ERROR RETURN IF OVERFLOW FLAG ON POPJ SP,0 ; NORMAL RETURN SUBTTL CODE GENERATION ROUTINES * CGFUN * PROCEDURE CGFUN ;..GENERATE CODE FOR CALLS ON STANDARD FUNCTIONS; ; ON ENTRY, FUNCTION LEXEME IS IN LOP; ; ARGUMENT LEXEME IS IN SYM; ; FOR LIBRARY FUNCTIONS, ARGUMENT WILL BE CONVERTED ; TO PROPER TYPE AND LOADED INTO A0. ; IN-LINE CODE WILL BE GENERATED FOR: ; INT ; BOOL ; ABS ; SIGN ; ENTIER ; RESULT IS A CLOSED PORTION WHOSE LEXEME IS IN SYM; BEGIN IF SYM IS AN ERROR LEXEME JUMPGE SYM,FALSE;$ THEN;..SET ERROR LEXEME AND LEAVE; ERRLEX; ELSE;..NO ERRORS YET ..... GO ON; BEGIN ;..SET REV OFF; MOVNI REV,SYM;$ IF LOP IS A LIBRARY FUNCTION HRRZ T,LOP;$ CAIGE T,PRASE;$ GOTO FALSE;$ THEN;..WE MUST CALL A SUBROUTINE; BEGIN IF SYM NEQ ARITHMETIC TN.ARITH(SYM); THEN FAIL(77,FRIED,SYM,NON-ARITHMETIC ARGUMENT FOR STANDARD LIBRARY FUNCTION); ELSE;..ARGUMENT IS ARITHMETIC; BEGIN IF LOP = REAL AND SYM NEQ REAL TLNN LOP,$TYPE-$R;$ TN.R (SYM); THEN;..ARGUMENT MUST BE CONVERTED TO REAL; ;CONVERT(REAL,SYM); MOVEI T,$R;$ CONVERT; ELSE;..LOP HAD BETTER BE LONG REAL; BEGIN ; [E044] IF LOP = LONG REAL AND SYM NEQ LONG REAL TLNN LOP,$TYPE-$LR;$ TN.LR (SYM); THEN;..ARGUMENT MUST BE CONVERTED TO LONG REAL; ;CONVERT(LONG REAL,SYM); MOVEI T,$LR;$ CONVERT; FI; EDIT(044); Dont force constants to D.P. unnecessarily ;.SYM IS LONG REAL - CHECK IF GENUINE ; [E044] IF SYM = PSEUDO-LONG CONSTANT ; [E044] TLNN SYM,$TYPE-$LR ; [E044] T.CONST (SYM) ; [E044] TLNE SYM,$CT-$IMM ; [E044] TLNN SYM,$DEC ; [E044] GOTO FALSE ; [E044] F.LOCN (T2,SYM) ; [E044] ADD T2,CONTAB ; [E044] SKIPL T4,3(T2) ; [E044] GOTO FALSE ; [E044] THEN;.MAKE IT A GENUINE LONG REAL CONSTANT; [E044] MOVE T3,2(T2) ; [E044] TLZ T4,(1B0) ; [E044] TOCT (2,SYM) ; [E044] FI; ; [E044] ENDD; ; [E044] FI IF SYM IS A POINTER T.PTR (SYM); THEN;..PUT ITS VALUE INTO A0; ;GO TO NEXT "THEN"; GOTO LCGFN1;$ FI IF VALUE OF SYM NOT IN A0 TN.AC0 (SYM); THEN;..ARGUMENT FOR A LIBRARY FUNCTION MUST BE IN A0; LCGFN1: LOAD(SYM,A0); FI REOPEN(SYM); ;..GENERATE CALL ON LIBRARY FUNCTION; IF LOP = LONG REAL T.LR(LOP); THEN MOVSI T,7777;$ ELSE MOVSI T,77;$ FI IORM T,HANDLE;$ ;PLUNK(PUSHJ,SP,LOP); MOVE T,OPPSJP;$ PLUNKI (LOP); ;LEX(SYM) _ (EXPR,SAME,STATEMENT,ACC); TLZ SYM,$KIND!$STATUS!$AM;$ TLO SYM,$EXP!$STMT!$ACC;$ CLOSE(SYM); ENDD FI ENDD ELSE;..NOT A LIBRARY FUNCTION - MUST BE IN-LINE; IF LOP = "INT" CAIE T,ZINT;$ GOTO FALSE;$ THEN;..BOOLEAN-TO-INTEGER TRANSFER FUNCTION -- NO CODE GENERATED; BEGIN IF SYM NEQ BOOLEAN TN.B (SYM); THEN FAIL(78,FRIED,SYM,NON-BOOLEAN ARGUMENT FOR "INT" FUNCTION); ELSE;..ARGUMENT IS BOOLEAN. MAKE IT AN INTEGER EXPR; BEGIN IF SYM IS A POINTER T.PTR (SYM); THEN;..LOAD VALUE INTO SAME ACC USED BY PTR; F.LOCN (T2,SYM); LOAD(SYM,@T2); ELSE;..NOT A POINTER; IF SYM IS SINGLE T.SINGLE(SYM); THEN;..MAKE IT A PORTION IN AN ACC; LOAD(SYM,ANYAC); FI FI ;LEX(SYM) _ (SAME,INTEGER,STATEMENT,SAME); TLZ SYM,$TYPE!$STATUS;$ TLO SYM,$I!$STMT;$ ENDD FI ENDD ELSE;..FUNCTION IS NOT "INT"; IF LOP = "BOOL" CAIE T,ZBOOL;$ GOTO FALSE;$ THEN;..INTEGER-TO-BOOLEAN TRANSFER FUNCTION -- NO CODE GENERATED; BEGIN IF SYM NEQ INTEGER TN.I (SYM); THEN FAIL(79,FRIED,SYM,NON-INTEGER ARGUMENT FOR "BOOL" FUNCTION); ELSE;..ARGUMENT IS INTEGER. MAKE IT A BOOLEAN EXPR; BEGIN IF SYM IS A POINTER T.PTR (SYM); THEN;..LOAD VALUE INTO SAME ACC USED BY PTR; F.LOCN (T2,SYM); LOAD(SYM,@T2); ELSE;..NOT A POINTER; IF SYM IS SINGLE T.SINGLE(SYM); THEN;..MAKE IT A PORTION IN AN ACC; LOAD(SYM,ANYAC); FI FI ;LEX(SYM) _ (SAME,BOOLEAN,STATEMENT,SAME); TLZ SYM,$TYPE!$STATUS;$ TLO SYM,$B!$STMT;$ ENDD FI ENDD ELSE;..FUNCTION IS NOT "INT" OR "BOOL"; IF SYM NEQ ARITHMETIC TN.ARITH(SYM); THEN FAIL(80,FRIED,SYM,NON-ARITHMETIC ARGUMENT FOR BUILT-IN FUNCTION); ELSE;..ARGUMENT IS ARITHMETIC; EDIT(044); Dont force constants to D.P. unnecessarily BEGIN; ; [E044] IF SYM = PSEUDO-LONG REAL CONSTANT ; [E044] TLNN SYM,$TYPE-$LR ; [E044] T.CONST (SYM) ; [E044] TLNE SYM,$CT-$IMM ; [E044] TLNN SYM,$DEC ; [E044] GOTO FALSE ; [E044] F.LOCN (T2,SYM) ; [E044] ADD T2,CONTAB ; [E044] SKIPL T4,3(T2) ; [E044] GOTO FALSE ; [E044] THEN;..CONVERT IT TO A REAL ; [E044] MOVE T3,A0 ; [E044] MOVE A0,2(T2) ; [E044] MOVE A1,3(T2) ; [E044] TLZ A1,(1B0) ; [E044] PUSHJ SP,CTLRR ; [E044] EXCH T3,A0 ; [E044] TLZ SYM,$TYPE TLO SYM,$R STOCON; ; [E044] HRRZ T,LOP ; [E044] FI; ; [E044] IF LOP = "ABS" CAIE T,ZABS;$ GOTO FALSE;$ THEN;..ABSOLUTE VALUE FUNCTION; BEGIN ;..RESULT WILL HAVE SAME TYPE AS ARGUMENT ; (TECHNICALLY NOT CORRECT ALGOL 60); IF SYM = LONG REAL T.LR (SYM); THEN;..WE MUST LOAD THE VALUE AND TEST IT; BEGIN IF SYM IS A POINTER T.PTR (SYM); THEN;..LOAD VALUE INTO SAME ACC USED BY PTR; F.LOCN (T2,SYM); LOAD(SYM,@T2); ELSE;..NOT A POINTER; IF SYM IS SINGLE T.SINGLE(SYM); THEN;..MAKE A PORTION TO LOAD SYM IN AN ACC; LOAD(SYM,ANYAC); FI FI REOPEN(SYM); ;..EMIT IN-LINE CODE TO TEST SIGN AND NEGATE NEG. VALUE; ;..SKIP THE NEGATION FOR POSITIVE VALUES; ;PLUNK(JUMPGE,SYM,.+2); MOVE T,OPABS1;$ F.LOCN (T1,SYM); PLUNK; ;..NEGATE THE NEGATIVE VALUE; ;PLUNK(LONG NEGATE,SYM,SYM+1); MOVE T,OPLNEG;$ F.LOCN (T1,SYM); MOVE T2,SYM;$ TLZ T2,777777-$AM;$ ADD T,T2;$ PLUNK; CLOSE(SYM); ENDD ELSE;..SYM IS INTEGER OR REAL; IF SYM IS AN EXPR OR A POINTER IN ACC T.ACC (SYM); THEN;..WE ALREADY HAVE A PORTION FOR SYM; BEGIN ;..APPEND CODE TO GET MAGNITUDE OF SYM; REOPEN(SYM); ;PLUNK(MABS,SYM,SYM); MOVE T,OPABS;$ F.LOCN (T1,SYM); PLUNK (SYM); CLOSE(SYM); ENDD ELSE;..NO PORTION YET. LOAD MAGNITUDE OF SINGLE ARGUMENT; ;LOADM(SYM,ANYAC); MOVEI T1,ANYAC;$ HLL T1,OPMVMS;$ PUSHJ SP,.LOAD;$ FI FI ;LEX(SYM) _ (EXPR,SAME,STATEMENT,ACC); TLZ SYM,$KIND!$STATUS!$AM;$ TLO SYM,$EXP!$STMT!$ACC;$ ENDD ELSE;..FUNCTION IS NOT "INT" OR "BOOL" OR "ABS"; IF LOP = "SIGN" CAIE T,ZSIGN;$ GOTO FALSE;$ THEN;..SIGN FUNCTION; BEGIN IF SYM IS A POINTER T.PTR (SYM); THEN;..LOAD VALUE INTO SAME ACC USED BY POINTER; F.LOCN (T2,SYM); LOAD(SYM,@T2); ELSE;..NOT A POINTER; IF SYM IS SINGLE T.SINGLE(SYM); THEN;..MAKE A PORTION TO LOAD SYM INTO AN ACC; LOAD(SYM,ANYAC); FI FI REOPEN(SYM); ;..EMIT IN-LINE CODE TO COMPUTE "SIGN" FUNCTION; ;..IF ARGUMENT = 0 THEN SIGN(ARG) = 0; ;PLUNK(JUMPE,SYM,.+3); MOVE T,OPSGN1;$ F.LOCN (T1,SYM); PLUNK; ;..SHIFT OUT ALL BUT SIGN BITS (YIELDS 0 OR -1); ;PLUNK(ASH,SYM,-43); MOVE T,OPSGN2;$ F.LOCN (T1,SYM); PLUNK; ;..SET LOW-ORDER BIT TO 1 (YIELDS 1 OR -1); ;PLUNK(TRO,SYM,1); MOVE T,OPSGN3;$ F.LOCN (T1,SYM); PLUNK; ;LEX(SYM) _ (EXPR,INTEGER,STATEMENT,ACC); TLZ SYM,$KIND!$TYPE!$STATUS!$AM;$ TLO SYM,$EXP!$I!$STMT!$ACC;$ CLOSE(SYM); ENDD ELSE;..FUNCTION IS NOT "INT" OR "BOOL" OR "ABS" OR "SIGN"; IF LOP = "ENTIER" CAIE T,ZENTIER;$ GOTO FALSE;$ THEN;..LARGEST-INTEGER FUNCTION; BEGIN IF SYM = INTEGER T.I (SYM); THEN ;CONVERT(REAL,SYM); MOVEI T,$R;$ CONVERT; FI IF SYM = LONG REAL T.LR (SYM); THEN;..LONG REAL ENTIER. CALL SUBROUTINE; BEGIN IF SYM IS A POINTER T.PTR (SYM); THEN;..MUST GET ITS VALUE; ;GO TO NEXT "THEN"; GOTO LCGFN2;$ FI IF VALUE OF SYM NOT IN A0 TN.AC0 (SYM); THEN;..LOAD IT INTO A0; LCGFN2: LOAD(SYM,A0); FI REOPEN(SYM); ;..GENERATE INST. TO CALL LONG REAL ENTIER SR; ;PLUNK(JSP,AX,ENTIEL); MOVE T,OPJSPX;$ PLUNKI; ;LEX(SYM) _ (EXPR,INTEGER,STATEMENT,ACC); TLZ SYM,$KIND!$TYPE!$STATUS!$AM;$ TLO SYM,$EXP!$I!$STMT!$ACC;$ CLOSE(SYM); ENDD ELSE;..ARGUMENT IS REAL. EMIT IN-LINE REAL ENTIER; BEGIN ;..GIVE SYM SPECIAL TYPE SO LOAD WILL USE 2 ACS; TLZ SYM,$TYPE;$ TLO SYM,$IDI;$ IF SYM IS A POINTER T.PTR (SYM); THEN;..MUST GET VALUE OF PTR INTO AN AC; ;..LOAD INTO SAME AC USED FOR PTR; F.LOCN (T2,SYM); LOAD (SYM,@T2); ELSE;..NOT A POINTER; BEGIN IF SYM IS SINGLE OR IN LAST AC TLNN SYM,$SINGLE;$ GOTO TRUE;$ F.LOCN (T,SYM); CAIE T,A13;$ GOTO FALSE;$ THEN;..MUST MOVE SYM TO A FREE AC PAIR; LOAD(SYM,ANYAC); FI ENDD FI IF LAST GENERATED INST. WAS "MOVEI" MOVE T,INDEX;$ HLRZ T2,-2(T);$ ANDI T2,777000;$ CAIE T2,_-22;$ GOTO FALSE;$ THEN;..SYM WAS AN IMMEDIATE REAL CONSTANT; ;.. BUT "LOAD" THOUGHT IT WAS INTEGER; ;..CHANGE INSTRUCTION TO "HRLZI"; MOVE T2,-2(T);$ TLZ T2,777000;$ TLO T2,_-22;$ MOVEM T2,-2(T);$ FI REOPEN(SYM); ;..EMIT IN-LINE CODE TO COMPUTE "ENTIER"; EDIT(031); CAN'T USE FIX OR FIXR, SO DO IT THE HARD WAY ;......SPLIT OFF EXPONENT; ;EMITCODE(MULI,SYM,400,2); MOVE T,OPENT1;$ F.LOCN (T1,SYM); HRLI T1,2;$ EMITCODE; ;..COMPLEMENT EXPONENT FOR NEGATIVE ARGUMENT; ;PLUNK(TSC,SYM,SYM); MOVE T,OPENT2;$ F.LOCN (T1,SYM); PLUNK (SYM); ;EXCHANGE EXPONENT AND FRACTION; ;PLUNK(EXCH,SYM+1,SYM); HRLZI T,_-22;$ F.LOCN (T1,SYM); ADDI T1,1;$ PLUNK (SYM); ;..SHIFT ARGUMENT TO ZERO EXPONENT; ;PLUNK(ASH,SYM,-243(SYM+1)); MOVE T,OPENT3;$ F.LOCN (T1,SYM); PLUNK; ;LEX(SYM)_(EXPR,INTEGER,STATEMENT,SYM); TLZ SYM,$KIND!$TYPE!$STATUS!$AM;$ TLO SYM,$EXP!$I!$STMT!$ACC;$ CLOSE(SYM); ENDD FI ENDD ;..ELSE NOT ENTIER; FI;..IF LOP = ENTIER FI;..IF LOP = SIGN FI;..IF LOP = ABS ENDD; FI;..IF SYM NEQ ARITHMETIC FI;..IF LOP = BOOL FI;.. IF LOP = INT FI;..IF LOP IS A LIBRARY FUNCTION ENDD; FI;..IF SYM IS AN ERROR LEXEME ENDD ; CGFUN SUBTTL CODE GENERATION ROUTINES * CGDOT * PROCEDURE CGDOT ;..GENERATE CODE TO LOAD OPERANDS FOR "DOT" OPERATOR; ; ON ENTRY, LEXEME FOR STRING POINTER IS IN LOP; ; LEXEME FOR INDEX IS IN SYM; ; CODE WILL BE GENERATED TO PUT STRING POINTER INTO A2 ; AND INDEX INTO A1; ; RESULT IS A SINGLE CLOSED PORTION WHOSE LEXEME IS IN SYM; BEGIN IF LOP IS AN ERROR LEXEME JUMPGE LOP,FALSE;$ THEN;..SET RESULT LEXEME AND LEAVE; ERRLEX; ELSE;..NO ERRORS YET ..... GO ON; BEGIN ;..SET REV OFF; MOVNI REV,SYM;$ IF SYM = SINGLE T.SINGLE(SYM); THEN;..NO PORTION YET FOR SYM; REOPEN(LOP); ELSE;..BOTH LOP AND SYM ARE PORTIONS -- JOIN THEM; BEGIN REVER; MERGEPORTIONS; COMBLEX; ENDD FI IF SYM IN AC2 TLNN SYM,$AMAC;$ TRNN SYM,2;$ JRST FALSE;$ TRNE SYM,-3;$ JRST FALSE;$ THEN BEGIN;..PUSH IT HRLZI T,();$ PLUNKI(SYM);$ ;..SYM _ SP TLZ SYM,$AM;$ TLO SYM,$SP;$ ;..SYM _ 0 TRZ SYM,-1;$ ;..SYM _ SYM + 1 HRLZI T,1;$ ADDM T,LEXEX;$ IF LOP IS ON STACK T.STK (LOP);$ THEN;..ADJUST STACK OFFSET SUBI LOP,1;$ FI; ENDD; FI; IF LOP NOT IN AC2 TLNE LOP,$AMAC;$ GOTO TRUE;$ HRRZ T,LOP;$ EDIT(225) ;DELETE IN PROC. CGDOT IN ALGFUN [JBS 4/11/80] ;[225] JUMPE T,FALSE;$ ; N.B. IF LOP IS IN AC0, ADDRESS IS IN AC2; CAIN T,A2;$ GOTO FALSE;$ THEN;..PUT IT INTO AC2; BEGIN ;..FUDGE MODE TO MOVE POINTER ITSELF (NOT @PTR); IF LOP IS ON THE STACK T.STK (LOP); THEN;..FUDGE AS STACKED EXPRESSION; TLZ LOP,$AM;$ TLO LOP,$SP;$ ELSE;..FUDGE AS EXPRESSION IN ACC; TLZ LOP,$AM;$ TLO LOP,$ACC;$ FI ;PLUNK(MOVE,AC2,LOP); MOVE T,OPMOVE;$ MOVEI T1,A2;$ PLUNK (LOP); ENDD FI IF SYM NOT IN AC1 TLNE SYM,$AMAC;$ GOTO TRUE;$ HRRZ T,SYM;$ CAIN T,A1;$ GOTO FALSE;$ THEN;..PUT IT INTO AC1; MOVE T,OPMVSM;$ MOVEI T1,A1;$ GLOAD; FI ;LEX(SYM) _ (VAR,STRING,REGULAR,PTR,AC2); TLZ SYM,$KIND!$TYPE!$STATUS!$AM;$ TLO SYM,$VAR!$S!$REG!$PTR;$ HRRI SYM,A2;$ CLOSE(SYM); ENDD FI ENDD ; CGDOT SUBTTL CODE GENERATION ROUTINES * CGFTEST * PROCEDURE CGFTEST ;..GENERATE CODE FOR THE "STEP-UNTIL" TEST IN A "FOR" STATEMENT ; ON ENTRY, LEXEME FOR CONTROLLED VARIABLE IS IN LOP; ; LEXEME FOR FINAL VALUE IS IN SYM; ; LEXEME FOR INCREMENT IS IN FBSYMSAVE; ; IF INCREMENT = CONSTANT, ITS SIGN WILL NOT BE ; TESTED AT RUN TIME. ; IF INCREMENT NEQ CONSTANT, THE GENERAL ALGOL TEST ; SEQUENCE WILL BE GENERATED; ; RESULT IS A CLOSED PORTION WHOSE LEXEME IS IN SYM; BEGIN IF LOP IS AN ERROR LEXEME JUMPGE LOP,FALSE;$ THEN;..SET ERROR LEXEME AND LEAVE; ERRLEX; ELSE;..LOP IS OK; IF INCREMENT IS AN ERROR LEXEME MOVE T,FBSYMSAVE;$ JUMPGE T,FALSE;$ THEN;..SET ERROR LEXEME AND LEAVE; ERRLEX; ELSE;..NO ERRORS YET ..... GO ON; BEGIN ;..SET REV OFF; MOVNI REV,SYM;$ ;..PUT INCREMENT LEXEME INTO A REGISTER; MOVE T2,FBSYMSAVE;$ IF INCREMENT IS CONSTANT T.CONST (T2); THEN;..CONSTANT INCREMENT. NO NEED TO TEST IT ON EACH CYCLE; BEGIN ;..PUT VALUE OF INCREMENT IN T3; IF INCREMENT = IMMEDIATE CONSTANT T.IMM (T2); THEN;..IMMEDIATE CONSTANT; BEGIN IF INCREMENT = INTEGER T.I (T2); THEN;..IMMEDIATE INTEGER CONSTANT; ;..RH(T3) _ INCREMENT; HRRZ T3,T2;$ ELSE;..IMMEDIATE REAL CONSTANT; ;..LH(T3) _ INCREMENT; HRLZ T3,T2;$ FI ENDD ELSE;..NON-IMMEDIATE CONSTANT; BEGIN ;T1 _ INCREMENT + CONSTANT TABLE BASE; F.LOCN (T1,T2); ADD T1,CONTAB;$ IF INCREMENT = LONG REAL T.LR (T2); THEN;..GET FIRST WORD OF LONG REAL CONSTANT; MOVE T3,2(T1);$ ELSE;..GET REAL OR INTEGER CONSTANT; MOVE T3,1(T1);$ FI ENDD FI ;..VALUE OF CONSTANT IS NOW IN T3. TEST ITS SIGN; EDIT(046); Do the correct thing for a zero increment IF CONSTANT GEQ 0 JUMPL T3,FALSE ; [E046] THEN;..CONSTANT >= 0. NORMAL TEST ; [E046] MOVE T,ZLEQ;$ ELSE;..CONSTANT < 0. REVERSE THE TEST ; [E046] MOVE T,ZGTE;$ FI MOVEM T,OP;$ ;..GENERATE CODE FOR THE RELATION. IF THE INCREMENT ;.. IS GREATER THAN 0, THE TEST WILL BE: ;.. IF CONT.VAR. > FINAL VAL. THEN GO TO ELM.-EXH.; ;.. OTHERWISE THE TEST WILL BE ;.. IF CONT.VAR. < FINAL VAL. THEN GO TO ELM.-EXH.; CGBIN; ;..NOW BACK UP THE STACK POINTER; UNSTACK; ;..NOW PUT IN THE JUMP TO "ELEMENT-EXHAUSTED"; REOPEN(SYM); IF THE LAST GENERATED INSTRUCTION = "SETO" MOVE T,INDEX;$ HLLZ T1,-1(T);$ TLZ T1,000777;$ CAME T1,OPSETO;$ GOTO FALSE;$ THEN;..NOTHING WAS STACKED. NO NEED TO GENERATE "TRUE" OR "FALSE"; BEGIN ;..REPLACE THE "TDZA" AND "SETO" BY A "JRST"; ;INDEX _ INDEX - 2; SUBI T,2;$ MOVEM T,INDEX;$ ;PLUNK(JRST,0,0); MOVE T,OPJRST;$ PLUNKI; ENDD ELSE;..CAN'T BACK UP - "UNSTACK" PUT IN AN INSTRUCTION; ;..APPEND A JUMPE; ;PLUNK(JUMPE,SYM,0); HLLZ T,-2(T);$ TLZ T,777000;$ TDO T,OPJMPE;$ F.LOCN (T1,SYM); PLUNKI; FI ENDD ELSE;..INCREMENT IS NOT CONSTANT. MUST GENERATE THE GENERAL TEST; BEGIN ;..TEST WILL BE ;.. IF (CONTR. VAR. - FINAL VALUE)*SIGN(INCREMENT) > 0 ;.. THEN GO TO ELEMENT-EXHAUSTED; ;.. ;..GENERATE CODE FOR (CONTR. VAR. - FINAL VALUE); MOVE T,ZMINUS;$ MOVEM T,OP;$ CGBIN; ;..LOP _ LEXEME AND LEXEX FOR (CONT. VAR. - FINAL VALUE); MOVE LOP,SYM;$ MOVE T,LEXEX;$ MOVEM T,LLEXEX;$ MOVE T,LEXEX+1;$ MOVEM T,LLEXEX+1;$ ;..SYM _ LEXEME AND LEXEX FOR INCREMENT; MOVE SYM,FBSYMSAVE;$ MOVE T,FBLEXSAVE;$ MOVEM T,LEXEX;$ MOVE T,FBCOMPSAVE;$ MOVEM T,LEXEX+1;$ ;..GENERATE CODE FOR MULTIPLICATION BY SIGN OF INCREMENT; ;..SET OP THOROUGHLY NON-REVERSIBLE; MOVEI T,0;$ MOVEM T,OP;$ SETUP;$ ;PLANT HRLZI T,();$ PLUNKI(SYM);$ IF LOP IS LONG.REAL; T.LR (LOP);$ THEN;..PLANT(LMOVN,LOP); MOVE T,OPLNEG;$ ELSE;..PLANT(MOVN,LOP); MOVE T,OPUMIN;$ FI; F.LOCN (T1,LOP);$ PLUNK(LOP);$ CLOSE(SYM); COMBLEX; ;..MAKE SURE THE STACK POINTER IS RESET; UNSTACK; ;..NOW APPEND THE TEST WHICH JUMPS TO "ELEMENT-EXHAUSTED"; REOPEN(SYM); ;PLUNK(JUMPG,LOP,0); MOVE T1,INDEX;$ HLLZ T,-1(T1);$ TLZ T,000037;$ CAMN T,[SUB SP,0];$ HLLZ T,-2(T1);$ TLZ T,777037;$ TDO T,OPJMPG;$ F.LOCN (T1,LOP); PLUNK; ENDD FI CLOSE(SYM); ENDD FI FI ENDD ; CGFTEST SUBTTL CODE GENERATION ROUTINES * CGINCR * PROCEDURE CGINCR ;..GENERATE EFFICIENT CODE FOR INCREMENTING A CONTROLLED VARIABLE; ; ON ENTRY, LEXEME FOR CONTROLLED VARIABLE IS IN LOP; ; LEXEME FOR INCREMENT IS IN SYM; ; NUMBER OF PREFERRED ACC IS IN PREFACC; ; IF INCREMENT = 1 THEN CODE IS "AOS" ; ELSE IF INCREMENT = -1 THEN CODE IS "SOS" ; ELSE IF INCREMENT = 0 THEN CODE IS "MOVE" ; ELSE CODE IS "ADDB"; ; CLOSED PORTION FOR ASSIGNMENT OF INCREMENTED VALUE ; IS GENERATED AND ITS RESULT LEXEME IS PUT IN SYM; BEGIN IF LOP IS AN ERROR LEXEME JUMPGE LOP,FALSE;$ THEN;..SET ERROR LEXEME AND LEAVE; ERRLEX; ELSE;..LOP IS OK; IF INCREMENT IS AN ERROR LEXEME JUMPGE SYM,FALSE;$ THEN;..SET ERROR LEXEME AND LEAVE; ERRLEX; ELSE;..NO ERRORS YET ..... GO ON; BEGIN ;..SET REV OFF; MOVNI REV,SYM;$ EDIT(046); Don't generate an "ADDB" for a zero increment ! IF SYM IS A CONSTANT WITH VALUE ZERO ; [E046] T.CONST (SYM) ; [E046] F.LOCN (T,SYM) ; [E046] TLNN SYM,$AM-$IMM ; [E046] JRST .+3 ; [E046] ADD T,CONTAB ; [E046] MOVE T,1(T) ; [E046] JUMPN T,FALSE ; [E046] THEN;..NO NEED TO GENERATE AN ADDB ; [E046] MOVE T4,OPMOVE ; [E046] GOTO LCGIN0 ; [E046] FI; ; [E046] IF LOP = INTEGER T.I (LOP); THEN;..LOP AND SYM ARE BOTH OF TYPE INTEGER; BEGIN IF VALUE OF INCREMENT = 1 F.LOCN (T,SYM); CAIN T,1;$ TLNE SYM,$AM-$IMM;$ GOTO FALSE;$ THEN;..INCREMENT = 1. DO THE INCREMENT WITH AN "AOS"; ;OPN _ "AOS"; MOVE T4,OPAOS;$ ELSE;..INCREMENT IS NOT 1; IF VALUE OF INCREMENT = -1 TLNN SYM,$AM-$CT;$ TLNN SYM,$CT-$IMM;$ GOTO FALSE;$ F.LOCN (T2,SYM); ADD T2,CONTAB;$ MOVN T,1(T2);$ CAIE T,1;$ GOTO FALSE;$ THEN;..INCREMENT = -1. DO THE INCREMENT WITH A "SOS"; ;OPN _ "SOS"; MOVE T4,OPSOS;$ ELSE;..INCREMENT IS NOT 1; ;..GO TO CODE WHICH LOADS INCREMENT INTO AN ACC; GOTO LCGIN1;$ FI FI LCGIN0: ; [E046] LABEL ADDED FOR ZERO CONSTANTS IF LOP IS NOT SINGLE TN.SINGLE(LOP); THEN;..WE ALREADY HAVE A PORTION FOR LOP; REOPEN(LOP); FI IF PREFACC = 0 SKIPE 0,PREFACC;$ GOTO FALSE;$ THEN;..CAN'T AOS OR SOS INTO AC0. CHANGE IT TO AC1 ; [E046] UNLESS OPCODE = MOVE, WHEN AC0 IS O.K. TLNE T4,174000 ; [E046] AOS 0,PREFACC;$ FI ;EMITCODE(OPN,PREFACC,LOP); MOVE T,T4;$ MOVE T1,PREFACC;$ HRLI T1,1;$ EMITCODE(LOP); ;LEX(SYM) _ (EXPR,SAME,SIMPLE,PREFACC); TLZ SYM,$KIND!$STATUS!$AM;$ TLO SYM,$EXP!$SIM!$ACC;$ HRR SYM,PREFACC;$ ENDD ELSE;..LOP MUST BE REAL; BEGIN IF SYM = INTEGER T.I (SYM); THEN;..CONVERT SYM TO REAL; ;CONVERT(REAL,SYM); MOVEI T,$R;$ CONVERT; FI LCGIN1: IF SYM IS A POINTER T.PTR (SYM); THEN;..MUST LOAD ITS VALUE; ;GO TO NEXT "THEN"; GOTO LCGIN2;$ FI IF SYM = SINGLE T.SINGLE(SYM); THEN;..INCREMENT IS NOT YET IN AN ACC. LOAD IT; LCGIN2: ;..LOAD INCREMENT INTO PREFERRED REGISTER (GIVEN BY PREFACC); MOVE T2,PREFACC;$ LOAD(SYM,@T2); ELSE;..VALUE OF INCREMENT IS ALREADY IN AN ACC; IF SYM = LOP F.LOCN (T,SYM); F.LOCN (T1,LOP); CAMN T,T1;$ TLNE LOP,$AMAC;$ GOTO FALSE;$ THEN;..ACC CONFLICT. RELOAD INCREMENT INTO PREFERRED ACC; GOTO LCGIN2;$ FI FI IF LOP = SINGLE T.SINGLE(LOP); THEN;..NO PORTION NEEDED FOR LOP; REOPEN(SYM); ELSE;..BOTH LOP AND SYM ARE PORTIONS; MERGEPORTIONS; FI ;..GENERATE AN ADD-TO-BOTH; F.TRANK (T,SYM); MOVE T,OPADDB(T);$ F.LOCN (T1,SYM); PLUNK (LOP); ;LEX(SYM) _ (EXPR,SAME,SIMPLE,ACC); TLZ SYM,$KIND!$STATUS!$AM;$ TLO SYM,$EXP!$SIM!$ACC;$ ENDD FI CLOSE(SYM); COMBASSIGN; ENDD FI FI ENDD ; CGINCR SUBTTL CODE GENERATION ROUTINES * CHECKARITH * PROCEDURE CHECKARITH; ;..FORCE BINARY OPERANDS TO HAVE MATCHING ARITHMETIC TYPES; ; ERROR FLAG (T) IS SET IF TYPES ARE NOT ARITHMETIC ; (INTEGER OR REAL OR LONG REAL); ; ON ENTRY, OPERAND LEXEMES ARE IN LOP AND SYM. ; IF TYPES OF OPERANDS ARE NOT ALIKE, CODE IS GENERATED TO ; CONVERT ONE OPERAND TO THE TYPE OF THE OTHER ; (IN THE ORDER INTEGER => REAL => LONG REAL). ; OPERAND PORTIONS ARE LEFT CLOSED WITH LEXEMES ; IN LOP AND SYM. BEGIN IF SYM IS INT OR REAL OR LONG REAL ; AND LOP IS INT OR REAL OR LONG REAL; TLNE SYM,$IRLR;$ T.IRLR (LOP); THEN;..OPERANDS HAVE TYPES WHICH CAN BE MATCHED; BEGIN IF SYM NEQ LOP F.TYPE (T,SYM); F.TYPE (T1,LOP); CAMN T,T1;$ GOTO FALSE;$ THEN;..TYPES DO NOT MATCH -- GENERATE CODE TO MATCH THEM; BEGIN IF SYM LSS LOP CAML T,T1;$ GOTO FALSE;$ THEN ;..CONVERT SYM TO THE TYPE OF LOP; PUSHJ SP,TCHECK ; [E044] ELSE ;..CONVERT LOP TO THE TYPE OF SYM; ;..MUST REVERSE LEXEMES AND LEXEXES BECAUSE CONVERT WORKS ON SYM; EXCH LOP,SYM;$ MOVNI REV,SYM+LOP(REV);$ PUSHJ SP,TCHECK ; [E044] EXCH SYM,LOP;$ MOVNI REV,SYM+LOP(REV);$ FI; ENDD; FI; EDIT(044);Don't force constants to D.P. unnecessarily ; TYPES MATCH - CHECK FOR PSEUDO-LONG REAL ; [E044] IF TYPE = LONG REAL ; [E044] T.LR (SYM) ; [E044] THEN; ; [E044] BEGIN; ; [E044] IF SYM = PSEUDO-LONG REAL CONSTANT & LOP # CONSTANT TLNE LOP,$CONST ; [E044] T.CONST (SYM) ; [E044] TLNE SYM,$CT-$IMM ; [E044] TLNN SYM,$DEC ; [E044] GOTO FALSE ; [E044] F.LOCN (T2,SYM) ; [E044] ADD T2,CONTAB ; [E044] SKIPL T4,3(T2) ; [E044] GOTO FALSE ; [E044] THEN;..CONVERT SYM TO A GENUINE LONG REAL CONSTANT MOVE T3,2(T2) ; [E044] TLZ T4,(1B0) ; [E044] TOCT (2,SYM) ; [E044] ELSE; ; [E044] BEGIN; ; [E044] IF LOP = PSEUDO-LONG REAL CONSTANT & SYM # CONSTANT TLNE SYM,$CONST ; [E044] T.CONST (LOP) ; [E044] TLNE LOP,$CT-$IMM ; [E044] TLNN LOP,$DEC ; [E044] GOTO FALSE ; [E044] F.LOCN (T2,LOP) ; [E044] ADD T2,CONTAB ; [E044] SKIPL T4,3(T2) ; [E044] GOTO FALSE ; [E044] THEN;..CONVERT LOP TO A GENUINE LONG REAL CONSTANT MOVE T3,2(T2) ; [E044] TLZ T4,(1B0) ; [E044] TOCT (2,LOP) ; [E044] FI; ; [E044] ENDD; ; [E044] FI; ; [E044] ENDD; ; [E044] FI; ; [E044] ;T_FALSE ; TURN ERROR FLAG OFF SETZ T,0;$ ENDD; ELSE;..TYPES CANNOT BE MATCHED; ;T_TRUE ; SET ERROR FLAG ON SETO T,0;$ FI; ENDD ; CHECKARITH TCHECK: Edit(044) ;New routine to match type of SYM to LOP BEGIN; ; [E044] IF LOP = PSEUDO-LONG CONSTANT & SYM # CONSTANT ; [E044] TLNN LOP,<$TYPE-$LR>!$CONST; TLNN SYM,$CONST ; [E044] GOTO FALSE ; [E044] TLNE LOP,$CT-$IMM ; [E044] TLNN LOP,$DEC ; [E044] GOTO FALSE ; [E044] F.LOCN (T2,LOP) ; [E044] ADD T2,CONTAB ; [E044] SKIPL A1,3(T2) ; [E044] GOTO FALSE ; [E044] THEN; FIRST WE MUST TRUNCATE LOP TO A REAL ; [E044] MOVE T3,A0 ; [E044] MOVE A0,2(T2) ; [E044] TLZ A1,(1B0) ; [E044] PUSHJ SP,CTLRR ; [E044] EXCH T3,A0 ; [E044] TLZ LOP,$TYPE ; [E044] TLO LOP,$R ; [E044] EXCH LOP,SYM ; [E044] PUSHJ SP,.STOCON ; [E044] EXCH LOP,SYM ; [E044] ; IF SYM # REAL, SKIP INTO THE "ELSE" CLAUSE ; [E044] TLNN SYM,$TYPE-$R ; [E044] ELSE; WE NEED TO CONVERT SYM TO THE TYPE OF LOP ; [E044] HLRZ T,LOP ; [E044] ANDI T,$TYPE ; [E044] PUSHJ SP,.CONVERT ; [E044] FI; ; [E044] POPJ SP, ; [E044] ENDD; TCHECK ; [E044] SUBTTL CODE GENERATION ROUTINES * COMBASSIGN * PROCEDURE COMBASSIGN; ;..GENERATE THE NEW LEXEX RESULTING FROM AN ASSIGNMENT; ; NEW LEXEX COMES FROM THOSE FOR SYM AND LOP. ; COMPUTES EXTYPE, BLOCK LEVEL, STACK ADDRESS, AND ; COMPOSITE NAME FOR THE ASSIGNMENT EXPRESSION. ; RESULT LEXEX IS ALWAYS THAT BELONGING TO SYM; BEGIN IF LEXEX(SYM) GEQ 0 F.BL (T1,SYM); JUMPL T1,FALSE;$ THEN;..SYM HAS EXTYPE "V". SET IT TO "P" AND SET C.N. _ 0; BEGIN ;SYM _ -1 (I.E., EXTYPE _ "P"); HRLZI T2,777000;$ S.BL (T2); ;SYM _ 0; SETZ T2,0;$ S.CN (T2); ENDD FI ;SYM _ SYM OR LOP; F.CN (T2,LOP); F.CN (T1,SYM); OR T2,T1;$ S.CN (T2); ;..BLOCK LEVEL _ MIN(BLOCK LEVELS); .... (SETS EXTYPE ALSO); IF LOP LSS SYM F.BL (T3,LOP); F.BL (T2,SYM); CAML T3,T2;$ GOTO FALSE;$ THEN ;SYM _ LOP; S.BL (T3); FI ;..STACK ADDRESS _ SUM OF STACK ADDRESSES; ;T2 _ LOP + SYM; F.SA (T2,LOP); F.SA (T1,SYM); ADD T2,T1;$ IF STACK ADDRESS GEQ 2^9 (512) TLNN T2,$LEXBL;$ GOTO FALSE;$ THEN;..STACK OVERFLOW ERROR; FAIL(66,FRIED,SYM,STACK-ADDRESS OVERFLOW); ELSE;..SYM _ T2; S.SA (T2); FI ENDD ; COMBASSIGN SUBTTL CODE GENERATION ROUTINES * COMBLEX * PROCEDURE COMBLEX ;..GENERATE THE NEW LEXEX RESULTING FROM A BINARY OPERATION; ; NEW LEXEX COMES FROM THOSE FOR SYM AND LOP. ; COMPUTES EXTYPE, BLOCK LEVEL, STACK ADDRESS, AND ; COMPOSITE NAME FOR THE RESULT EXPRESSION. ; RESULT LEXEX IS ALWAYS THAT BELONGING TO SYM; BEGIN IF EXTYPE(LOP) = EXTYPE(SYM) F.BL (T3,LOP); F.BL (T2,SYM); MOVE T,T2;$ XOR T,T3;$ JUMPL T,FALSE;$ THEN;..EXTYPES MATCH (BOTH "P" OR BOTH "V"); ;SYM _ LOP OR SYM; F.CN (T1,LOP); F.CN (T,SYM); OR T,T1;$ S.CN (T); ELSE;..EXTYPES DO NOT MATCH. RESULT GETS C.N. OF TYPE "P" LEXEME; IF LOP LSS 0 JUMPGE T3,FALSE;$ THEN;..LOP HAS EXTYPE "P". GRAB ITS C. NAME FOR THE RESULT; ;SYM _ LOP; F.CN (T,LOP); S.CN (T); ;..ELSE SYM HAS EXTYPE "P" AND ITS C.N. IS THAT OF THE RESULT; FI FI ;..BLOCK LEVEL _ MIN(BLOCK LEVELS); .... (SETS EXTYPE ALSO); IF LOP LSS SYM CAML T3,T2;$ GOTO FALSE;$ THEN ;SYM _ LOP; S.BL (T3); FI ;..STACK ADDRESS _ SUM OF STACK ADDRESSES; ;T2 _ LOP + SYM; F.SA (T2,LOP); F.SA (T1,SYM); ADD T2,T1;$ IF STACK ADDRESS GEQ 2^9 (512) TLNN T2,$LEXBL;$ GOTO FALSE;$ THEN;..STACK OVERFLOW ERROR; FAIL(66,FRIED,SYM,STACK-ADDRESS OVERFLOW); ELSE;..SYM _ T2; S.SA (T2); FI ENDD ; COMBLEX SUBTTL CODE GENERATION ROUTINES * CONVERT * PROCEDURE CONVERT ;..GENERATES CODE TO CONVERT AN OPERAND TO A GIVEN TYPE; ; ON ENTRY, OPERAND LEXEME IS IN SYM; ; DESIRED TYPE IS IN T; ; IF OPERAND IS A CONSTANT, A NEW CONSTANT WILL BE GENERATED ; (AND NO CODE WILL BE PRODUCED). ; RESULT IS A CLOSED PORTION WHOSE LEXEME IS IN SYM; BEGIN OWN RESTYPE; ;..TEMP FOR THE DESIRED TYPE BITS; ;RESTYPE _ T; MOVEM T,RESTYPE;$ IF SYM = CONSTANT T.CONST (SYM); THEN;..OPERAND IS A CONSTANT. WE CAN DO THE CONVERSION RIGHT NOW; BEGIN ;..SAVE A0 (GBREG); MOVE T3,A0;$ IF SYM = IMMEDIATE T.IMM (SYM); THEN;..IMMEDIATE CONSTANT. PUT VALUE INTO A0; BEGIN IF SYM = INTEGER T.I (SYM); THEN ;RH(A0) _ SYM; HRRZ A0,SYM;$ ELSE;..IMMEDIATE REAL CONSTANT; ;LH(A0) _ SYM; HRLZ A0,SYM;$ FI ENDD ELSE;..NON-IMMEDIATE CONSTANT; BEGIN ;T2 _ SYM + CONSTANT TABLE BASE; F.LOCN (T2,SYM); ADD T2,CONTAB;$ IF SYM = LONG REAL T.LR (SYM); THEN;..LONG CONSTANT; ;..PUT CONSTANT INTO A0 AND A1; ;.. * * * NOTE THAT A1 IS THE SAME REGISTER AS T; MOVE A0,2(T2);$ MOVE A1,3(T2);$ TLZ A1,(1B0) ; [E044] ELSE;..SHORT CONSTANT; ;..PUT CONSTANT INTO A0; MOVE A0,1(T2);$ FI ENDD FI ;..EXECUTE APPROPRIATE CONVERSION ROUTINE (RESULT GOES TO A0 (AND A1)); ;.. * * * NOTE THAT A2 (T1) MAY BE CLOBBERED HERE; MOVE T2,RESTYPE;$ LSH T2,-14;$ F.TRANK (T1,SYM); LSH T1,2;$ OR T2,T1;$ XCT OPCONC-1(T2);$ ;LEX(SYM) _ (SAME,RESTYPE,SAME,SAME); TLZ SYM,$TYPE;$ TSO SYM,RESTYPE;$ ;..WE NOW HAVE A NEW OPERAND. IT MUST BE PUT IN THE CONSTANT TABLE; ;..MOVE HIGH ORDER WORD OF CONSTANT TO T3 AND RESTORE A0; EXCH T3,A0;$ IF SYM = LONG REAL T.LR (SYM); THEN;..LONG REAL CONSTANT; BEGIN ;..MOVE LOW ORDER WORD OF CONSTANT TO T4; MOVE T4,A1;$ TLO T4,(1B0) ; [E044] ;..PUT IN CONSTANT TABLE (T3,T4); TOCT(2,SYM); ENDD ELSE;..SHORT CONSTANT; STOCON; FI ENDD ELSE;..OPERAND IS NOT A CONSTANT; BEGIN ;..OPERAND MUST BE IN AC0 (AND 1) FOR THE CONVERSION ROUTINES; IF SYM IS A POINTER T.PTR (SYM); THEN;..LOAD ITS VALUE INTO AC0; GOTO LCONV1;$ FI IF VALUE OF SYM NOT IN AC0 TN.AC0 (SYM); THEN;..PUT IT IN; LCONV1: ;..GENERATE CODE TO MOVE OPERAND TO AC0 (AND 1); LOAD(SYM,A0); FI REOPEN(SYM); ;..GENERATE CALL ON CONVERSION SUBROUTINE; ;PLUNKI(CONVERTOP); MOVE T1,RESTYPE;$ LSH T1,-14;$ F.TRANK (T,SYM); LSH T,2;$ OR T,T1;$ MOVE T,OPCONV-1(T);$ PLUNKI; ;..BOOK A1 IN HANDLE HRLZI T,2;$ IORM T,HANDLE;$ ;LEX(SYM) _ (EXPR,RESTYPE,SIMPLE,AC0); TLZ SYM,$KIND!$TYPE!$STATUS!$AM;$ TSO SYM,RESTYPE;$ TLO SYM,$EXP!$SIM!$ACC;$ HRRI SYM,0;$ CLOSE(SYM); ENDD FI ENDD ; CONVERT SUBTTL CODE GENERATION ROUTINES * MARRY * PROCEDURE MARRY ;..MAKE A SINGLE OPEN PORTION FOR TWO BINARY OPERANDS, ; REVERSING THE ORDER IF POSSIBLE; ; ON ENTRY, LEXEMES FOR THE OPERANDS ARE IN LOP AND SYM; ; UNLESS THE OPERATION = "^", MARRY WILL MAKE SURE THAT ; THE RESULT PORTION INCLUDES CODE TO LOAD ; THE "LEFT" OPERAND INTO AN AC; BEGIN IF SYM = SINGLE T.SINGLE(SYM); THEN;..SYM IS NOT A PORTION; BEGIN IF LOP NEQ SINGLE TN.SINGLE(LOP); THEN;..LOP IS A PORTION AND SYM IS NOT; REOPEN(LOP); ELSE;..BOTH LOP AND SYM ARE SINGLE; BEGIN IF OP NEQ "^" TN.OPER (ZPOW); THEN;..MAKE A PORTION TO PUT A VALUE IN AN ACC; BEGIN IF LOP = ONE-WORD CONSTANT AND OP IS REVERSIBLE TLNN LOP,$VAR1;$ T.CONST (LOP); TRNN T,$ODROP;$ GOTO FALSE;$ THEN;..REVERSE THE ORDER SO VARIABLE IS LOADED FIRST; BEGIN ;..EXCHANGE THE LEXEMES; EXCH LOP,SYM;$ ;..SET REV ON; MOVNI REV,LOP;$ ENDD FI LOAD(LOP,ANYAC); REOPEN(LOP); ENDD ;..ELSE NO PORTIONS ARE NECESSARY FOR POWERS; FI ENDD FI ENDD ELSE;..SYM IS A PORTION; BEGIN REVORDER; IF LOP = SINGLE T.SINGLE(LOP); THEN;..AFTER REORDERING, LOP IS STILL NOT A PORTION. ;..MAKE IT ONE AND MERGE WITH SYM; BEGIN LOAD(LOP,ANYAC); MERGEPORTIONS; ENDD ELSE;..LOP IS A PORTION AFTER REORDERING; IF SYM = SINGLE T.SINGLE(SYM); THEN;..THERE IS ONLY ONE PORTION; REOPEN(LOP); ELSE;..TWO PORTIONS; BEGIN IF LOP IS A POINTER T.PTR (LOP); THEN;..WE MAY HAVE TO EVALUATE LOP BEFORE MERGING; BEGIN IF REVERSAL NOT ALLOWED OR LOP IS A ONE WORD OPERAND JUMPN T3,TRUE;$ ;..(T3 IS A SWITCH WHICH IS SET BY REVORDER); T.ONE (LOP); THEN;..EVALUATE LOP NOW; ;..LOAD VALUE OF LOP INTO SAME ACC USED BY POINTER; F.LOCN (T2,LOP); LOAD(LOP,@T2); FI ENDD FI MERGEPORTIONS; ENDD FI FI ENDD FI ENDD ; MARRY SUBTTL CODE GENERATION ROUTINES * SETUP * PROCEDURE SETUP ;..SET UP THE OPERANDS FOR A BINARY OPERATION BY ; MAKING A SINGLE OPEN PORTION, REORDERED IF POSSIBLE, ; WITH THE VALUE OF THE (REORDERED) LEFT OPD (LOP) IN AN AC; ; ON ENTRY, OPERAND LEXEMES ARE IN LOP AND SYM; ; SETUP MAY CHANGE THE OPERATOR IF THE OPERATION ; IS REVERSIBLE, (E.G., "<" => ">", LFDV => RLFDV). BEGIN ;..FIRST MAKE A SINGLE OPEN PORTION FOR THE OPERANDS; MARRY; IF REV T.REV; THEN;..PORTIONS WERE REVERSED BY MARRY; BEGIN ;..EXCHANGE THE LEXEMES AGAIN; EXCH LOP,SYM;$ ;..SET REV OFF; MOVNI REV,SYM;$ ENDD FI IF LOP NOT AN EXPRESSION IN ACC TN.ACC (LOP); THEN;..VALUE OF LOP IS NOT NOW IN AN AC; BEGIN IF VALUE OF SYM IN AN ACC TLNE SYM,$AM-$ACC;$ GOTO FALSE;$ THEN;..WE MAY BE ABLE TO DO AN OPERATOR REVERSAL; BEGIN IF OP IS NOT REVERSIBLE MOVE T,OP;$ TRNE T,$ODROP;$ GOTO FALSE;$ THEN;..OP IS NOT USUALLY REVERSIBLE; BEGIN IF SYM = LONG REAL T.LR (SYM); THEN;..OPERANDS ARE LONG REAL; BEGIN IF OP = SLASH T.OPER (ZSLASH); THEN;..WE CAN CALL A REVERSE DIVIDE SR; GOTO LSETU1;$ FI IF OP = "-" T.OPER (ZMINUS); THEN;..WE CAN CALL A REVERSE SUBTRACT SR; GOTO LSETU1;$ FI ENDD FI ;..NO CHANCE OF OPERATOR REVERSAL. LOAD VALUE OF LOP INTO AN AC; GOTO LSETU2;$ ENDD ELSE;..OP IS REVERSIBLE; BEGIN LSETU3: IF OP IS NOT COMMUTATIVE MOVE T,OP;$ TRNE T,$ODCOP;$ GOTO FALSE;$ THEN;..MAKE OP INTO ITS REVERSE; LSETU1: ;..OP _ REVERSE(OP); MOVE T,OP;$ ADDI T,2_^D8;$ MOVEM T,OP;$ ;..ELSE COMMUTATIVE OP IS ITS OWN REVERSE; FI ;..REVERSE THE OPERANDS BY EXCHANGING LEXEMES AND LEXEXES; MOVE T,LEXEX;$ EXCH T,LEXEX+2;$ MOVEM T,LEXEX;$ MOVE T,LEXEX+1;$ EXCH T,LEXEX+3;$ MOVEM T,LEXEX+1;$ EXCH LOP,SYM;$ ENDD FI ENDD ELSE;..NEITHER SYM NOR LOP HAS A LOADED VALUE; BEGIN IF LOP = SINGLE AND SYM = POINTER AND OP IS REVERSIBLE T.PTR (SYM); MOVE T,OP;$ TRNE T,$ODROP;$ TLNE LOP,$SINGLE;$ GOTO FALSE;$ THEN;..WE SHOULD LOAD THE VALUE OF SYM NOW; BEGIN ;..LOAD VALUE OF SYM INTO SAME ACC, LEAVING PORTION OPEN; MOVE T,OPMVSM;$ F.LOCN (T1,SYM); GLOAD; ;..GO BACK TO REVERSE THE LEXEMES; GOTO LSETU3;$ ENDD FI LSETU2: ;..PUT THE VALUE OF LOP IN AN AC; IF LOP IS A POINTER T.PTR (LOP); THEN;..USE SAME ACC FOR VALUE AS FOR POINTER; F.LOCN (T1,LOP); ELSE;..USE NEXT FREE ACC; MOVEI T1,ANYAC;$ FI IF OP = "DIV" OR "REM" MOVE T,OP;$ CAMN T,ZDIV;$ GOTO TRUE;$ CAME T,ZREM;$ GOTO FALSE;$ THEN;..GIVE LOP SPECIAL TYPE SO LOAD WILL USE 2 AC'S; TLZ LOP,$TYPE;$ TLO LOP,$IDI;$ FI ;..LOAD THE VALUE, LEAVING THE PORTION OPEN; MOVE T,OPMVLP;$ GLOAD; ENDD FI ENDD; FI ENDD ; SETUP SUBTTL CODE GENERATION ROUTINES * STOCON * PROCEDURE STOCON ;..FIX UP LEXEME AND CONSTANT TABLE (IF NECESSARY) ; FOR A NEWLY GENERATED ONE WORD CONSTANT; ; ON ENTRY, VALUE OF CONSTANT IS IN T3; ; PARTIAL LEXEME FOR CONSTANT IS IN SYM; ; IF CONSTANT CAN BE IMMEDIATE, IT WILL BE STORED IN THE LEXEME; ; IF NOT IT WILL BE PUT INTO THE CONSTANT TABLE; ; COMPLETED LEXEME WILL BE PUT INTO SYM; BEGIN IF LEFT HALF OF CONSTANT = 0 AND SYM NEQ REAL TLNN T3,777777;$ TN.R (SYM); THEN;..WE HAVE A BOOLEAN OR INTEGER IMMEDIATE CONSTANT; ;LEX(SYM) _ (IMMED,SAME,SIMPLE,RH(T3)); TLZ SYM,$STATUS!$AM;$ TLO SYM,$SIM!$IMM;$ HRR SYM,T3;$ ELSE;..IT MAY BE REAL IMMEDIATE; IF RIGHT HALF OF CONSTANT = 0 AND SYM = REAL TRNN T3,777777;$ T.R (SYM); THEN;..WE HAVE A REAL IMMEDIATE CONSTANT; ;LEX(SYM) _ (IMMED,SAME,SIMPLE,LH(T3)); TLZ SYM,$STATUS!$AM;$ TLO SYM,$SIM!$IMM;$ HLR SYM,T3;$ ELSE;..CONSTANT CANNOT BE IMMEDIATE; ;..PUT CONSTANT IN TABLE; TOCT(1,SYM); FI FI ENDD ; STOCON ENDD; END OF MODULE MFUN LIT END