Trailing-Edge
-
PDP-10 Archives
-
ALGOL-20_1-29-82
-
algol-sources/algfun.mac
There are 8 other files named algfun.mac in the archive. Click here to see a list.
;
;
;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 CTILR,CTLRI,CTLRR
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
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
CTLRI: DFAD A0,[
EXP 0.5,0.0]
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
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,
CTILR: ASHC A0,-^D35 ; SHIFT SIGNIFICANCE TO A1
TLC A0,276000 ; JUGGLE THE EXPONENT
DFAD A0,[
EXP 0.0,0.0] ; NORMALIZE
POPJ SP, ; AND RETURN
CTLRR: 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,
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: FLTR A0,A0 ; 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
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
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
EDIT(225) ;DELETE IN PROC. CGDOT IN ALGFUN [JBS 4/11/80]
; 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;
DMOVE A0,2(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