Trailing-Edge
-
PDP-10 Archives
-
ap-5069c-sb
-
algfun.mac
There are 8 other files named algfun.mac in the archive. Click here to see a list.
;
;
;
;
;
;
; COPYRIGHT (C) 1975,1976,1977,1978
; DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
; SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY 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 EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
; AGREES TO THESE LICENSE TERMS. TITLE TO AND OWNERSHIP OF THE
; SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
; NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
; EQUIPMENT CORPORATION.
;
; DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
; SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
;
;SUBTTL CODE GENERATION ROUTINES PART 2
; COPYRIGHT 1971,1972,1973,1974 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
; 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: 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,
CTRI: FADRI A0,(0.5) ; CTRI -- ADD 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<TYPE> NEQ ARITHMETIC
TN.ARITH(SYM);
THEN
FAIL(77,FRIED,SYM,NON-ARITHMETIC ARGUMENT FOR STANDARD LIBRARY FUNCTION);
ELSE;..ARGUMENT IS ARITHMETIC;
BEGIN
IF LOP<TYPE> = REAL AND SYM<TYPE> 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<TYPE> = LONG REAL AND SYM<TYPE> 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<TYPE> = 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<TYPE> 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<TYPE> 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<TYPE> 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<TYPE> = 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<TYPE> = INTEGER
T.I (SYM);
THEN
;CONVERT(REAL,SYM);
MOVEI T,$R;$
CONVERT;
FI
IF SYM<TYPE> = 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 <AC13>
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,<MOVEI 0,0>_-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,<HRLZI 0,0>_-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,<EXCH 0,0>_-22;$
F.LOCN (T1,SYM);
ADDI T1,1;$
PLUNK (SYM);
;..SHIFT ARGUMENT TO ZERO EXPONENT;
;PLUNK(ASH,SYM<LOCN>,-243(SYM<LOCN>+1));
MOVE T,OPENT3;$
F.LOCN (T1,SYM);
PLUNK;
;LEX(SYM)_(EXPR,INTEGER,STATEMENT,SYM<LOCN>);
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<TYPE> 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,(<PUSH SP,0>);$
PLUNKI(SYM);$
;..SYM<AM> _ SP
TLZ SYM,$AM;$
TLO SYM,$SP;$
;..SYM<RHS> _ 0
TRZ SYM,-1;$
;..SYM<SA> _ SYM<SA> + 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;$
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<TYPE> = INTEGER
T.I (T2);
THEN;..IMMEDIATE INTEGER CONSTANT;
;..RH(T3) _ INCREMENT<LOCN>;
HRRZ T3,T2;$
ELSE;..IMMEDIATE REAL CONSTANT;
;..LH(T3) _ INCREMENT<LOCN>;
HRLZ T3,T2;$
FI
ENDD
ELSE;..NON-IMMEDIATE CONSTANT;
BEGIN
;T1 _ INCREMENT<LOCN> + CONSTANT TABLE BASE;
F.LOCN (T1,T2);
ADD T1,CONTAB;$
IF INCREMENT<TYPE> = 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 <SKIPGE SYM>
HRLZI T,(<SKIPGE>);$
PLUNKI(SYM);$
IF LOP<TYPE> 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<TYPE> = 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<TYPE> MUST BE REAL;
BEGIN
IF SYM<TYPE> = 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<LOCN> = LOP<LOCN>
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<TYPE> IS INT OR REAL OR LONG REAL
; AND LOP<TYPE> IS INT OR REAL OR LONG REAL;
TLNE SYM,$IRLR;$
T.IRLR (LOP);
THEN;..OPERANDS HAVE TYPES WHICH CAN BE MATCHED;
BEGIN
IF SYM<TYPE> NEQ LOP<TYPE>
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<TYPE> LSS LOP<TYPE>
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<TYPE> # 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<BLOCK LEVEL> _ -1 (I.E., EXTYPE _ "P");
HRLZI T2,777000;$
S.BL (T2);
;SYM<COMPOSITE NAME> _ 0;
SETZ T2,0;$
S.CN (T2);
ENDD
FI
;SYM<COMPOSITE NAME> _ SYM<C. NAME> OR LOP<C. NAME>;
F.CN (T2,LOP);
F.CN (T1,SYM);
OR T2,T1;$
S.CN (T2);
;..BLOCK LEVEL _ MIN(BLOCK LEVELS); .... (SETS EXTYPE ALSO);
IF LOP<BLOCK LEVEL> LSS SYM<BLOCK LEVEL>
F.BL (T3,LOP);
F.BL (T2,SYM);
CAML T3,T2;$
GOTO FALSE;$
THEN
;SYM<BLOCK LEVEL> _ LOP<BLOCK LEVEL>;
S.BL (T3);
FI
;..STACK ADDRESS _ SUM OF STACK ADDRESSES;
;T2 _ LOP<STACK ADDRESS> + SYM<STACK ADDRESS>;
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<STACK ADDRESS> _ 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<COMPOSITE NAME> _ LOP<C. NAME> OR SYM<C. NAME>;
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<LEXEX> LSS 0
JUMPGE T3,FALSE;$
THEN;..LOP HAS EXTYPE "P". GRAB ITS C. NAME FOR THE RESULT;
;SYM<COMPOSITE NAME> _ LOP<C. NAME>;
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<BLOCK LEVEL> LSS SYM<BLOCK LEVEL>
CAML T3,T2;$
GOTO FALSE;$
THEN
;SYM<BLOCK LEVEL> _ LOP<BLOCK LEVEL>;
S.BL (T3);
FI
;..STACK ADDRESS _ SUM OF STACK ADDRESSES;
;T2 _ LOP<STACK ADDRESS> + SYM<STACK ADDRESS>;
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<STACK ADDRESS> _ 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<TYPE> = INTEGER
T.I (SYM);
THEN
;RH(A0) _ SYM<LOCN>;
HRRZ A0,SYM;$
ELSE;..IMMEDIATE REAL CONSTANT;
;LH(A0) _ SYM<LOCN>;
HRLZ A0,SYM;$
FI
ENDD
ELSE;..NON-IMMEDIATE CONSTANT;
BEGIN
;T2 _ SYM<LOCN> + CONSTANT TABLE BASE;
F.LOCN (T2,SYM);
ADD T2,CONTAB;$
IF SYM<TYPE> = 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<TYPE> = 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<TYPE> = 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<TYPE> 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<TYPE> = 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