Trailing-Edge
-
PDP-10 Archives
-
AP-5471B-BM
-
sources/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 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;$
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 E