Trailing-Edge
-
PDP-10 Archives
-
BB-D480C-SB_1981
-
expres.bli
There are 12 other files named expres.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
! OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!COPYRIGHT (C) 1973,1981 BY DIGITAL EQUIPMENT CORPORATION
!AUTHOR: F.J. INFANTE, D. B. TOLMAN/DCE/JNG/TFV/EGM/EDS
MODULE EXPRES(RESERVE(0,1,2,3),SREG=#17,FREG=#16,VREG=#15,DREGS=4,GLOROUTINES)=
BEGIN
GLOBAL BIND EXPREV = 6^24 + 0^18 + 40; ! Version Date: 22-Sep-81
%(
***** Begin Revision History *****
24 ----- ----- CODE TO WORRY ABOUT STATEMENT FUNCTION DUMMIES
HAS BEEN REMOVED SINCE THEY ARE NOW
SPECIAL GENERATED SUBLOCAL VARIABLES
CODE TO WORRY ABOUT VARIABLES THE SAME AS FUNCTION
NAMES HAS BEEN REMOVED SINCE THE NAME OF THE FUNCTION
CURRENTLY BEING COMPILED NO LONGER HAS FNNAME SET
ON IT
25 ----- ----- DON'T LET DUMMY ARGUMENTS WHICH HAPPEN TO BE LIBRARY
FUNCTION NAMES TURN INTO LIBRARY FUNCTION CALLS
26 _____ _____ PICK UP THE .ED NAMES FOR ACTUAL PARAMETER
LIBRARY FUNCITONS
THE ROUTINE LIBSRCH HAS BEEN CHANGED TO SRCHLIB
WITH A SYMBOL TABLE POINTER AS PARAMETER
27 ----- ----- CLEAR THE ARG1PTR FOR NEGNOT NODES IN MACRO
BLDTREE
28 ----- ----- IMMEDIATELY NEGATE ALL CONSTANTS PRECEEDED BY
UNARY MINUS. ROUTINE PRIMITIVE
29 ----- ----- DETECT A .NOT. B IN MACRO BLDTREE
30 ----- ----- REMOVE THE CONVERSION NODE INSERT CODE
FOR UNARY NEGATION OF DOUBLE OCTAL AND LET
NEGCNST DO IT NOW THAT CONSTANTS ARE IMMEDIATELY NEGATED
ROUTINE PRIMITIVE
31 ----- ----- FIX PRIMITIVE SO THAT IT WILL NOT MAKE NAMSET
CALLS FOR LIBRARY ROUTINE ACTUAL PARAMETERS
32 542 22147 MAKE NOT NODES BE OF TYPE LOGICAL, (DCE)
33 626 23169 DON'T ALLOW FUNCTION OR ARRAY NAMES WITHOUT
PARENTHESIZED LISTS TO APPEAR IN EXPRESSIONS
IN ARGUMENT LISTS, E.G. CATCH FN(A+3), WHERE
FN IS A FUNCTION AND A IS AN ARRAY., (JNG)
***** Begin Version 6 *****
34 761 TFV 1-Mar-80 -----
Choose either KLDP or GFLOATING dotted name for generic functions.
Convert DP to SP based on /GFLOATING
35 1004 TFV 1-Jul-80 ------
Fix dottednames to lookup /GFLOATING routines only for doubleprecision.
Replace VREG with temp.
36 1043 EGM 19-Jan-81 20-15466
Generate warning for consecutive arithmetic operands.
37 1056 DCE 3-Mar-81 -----
Put type conversion node beneath .NOT. node if necessary (for register
allocation especially).
38 1072 CKS 22-May-81 Q20-1524
Remove consecutive arithmetic operators illegal message until it can be
put under flagger switch
40 1122 EDS 22-Sep-81 10-31589
Fix PRIMITIVE to detect invalid complex expression.
***** End Revision History *****
)%
REQUIRE LEXNAM.BLI;
REQUIRE ASHELP.BLI;
SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;
BIND PRECEDENCE = !THE PRECEDENCE OF THE EXPRESSION OPERATORS
PLIT( %PRECEDENCE,,OPERATOR FLAG COMBINED IF NEGATIVE%
PRCDNCE0, !NULL FOR INDEXING
PRCDNCE1,
PRCDNCE2,
PRCDNCE3,
PRCDNCE4,
PRCDNCE5,
PRCDNCE6,
PRCDNCE7,
PRCDNCE8,
PRCDNCE9,
PRCDNCE10,
PRCDNCE11,
PRCDNCE12,
PRCDNCE13,
PRCDNCE14,
PRCDNCE15,
PRCDNCE16,
PRCDNCE17,
PRCDNCE18,
PRCDNCE19,
PRCDNCE20,
PRCDNCE21,
PRCDNCE22,
);
MACRO OPER(X)= (.PRECEDENCE[X] LSS 0)$;
MACRO ERR0(X)= RETURN FATLEX( X, .LEXNAME[.LEXL<LEFT>], E0<0,0> ) $;
MACRO MAKENEGAT = (LOCAL BASE NEGNOD;
NAME _ EXPTAB;
NEGNOD _ NEWENTRY();
NEGNOD[OPRCLS]_ NEGNOT; NEGNOD[OPERSP]_NEGOP;
.NEGNOD
)$;
%[1043]% BIND ARITHOPFLAGS = ! A parallel table for PRECEDENCE
%[1043]% PLIT ( ! flagging arithmetic operators
%[1043]% %[IDENTIFIER:LOGICAL MATCH]% 0,0,0,0,0,0,0,0,0,0,0,
%[1043]% %[POWER]% 1,
%[1043]% %[ANDSGN:DOLLAR]% 0,0,0,0,0,0,
%[1043]% %[MINUS:TIMES]% 1,1,1,1,
%[1043]% %[EQUAL]% 0);
%[1043]% OWN CONSECOPS, ! Consecutive ops seen flag
%[1043]% ARITHOPSEEN; ! Arithmetic operator seen flag
%[1043]% EXTERNAL E148; ! Consecutive arithmetic operators warning
EXTERNAL NEWENTRY,LEXEMEGEN,LEXL,LSAVE,STK,SP,LEXICAL,GSTLEXEME,FATLEX,LEXNAME;
GLOBAL ROUTINE EXPRESSION=
BEGIN
%
ROUTINE IS AN "ACTION" ROUTINE CALLED BY THE SYNTAX ANALYSER
TO PARSE A GENERAL FORTRAN EXPRESSION.
RETURNS A PTR TO AN EXPRESSION NODE IN STK[SP_.SP+1]
%
EXTERNAL SP,STK,LOGEXPRESSION;
LOCAL LSP; !LOCAL STK PTR;
%[1043]% CONSECOPS _ 0; ! No consecutive operators seen
LSP _ .SP;
IF .LSAVE EQL 0
THEN (LSAVE_-1;LEXL _ LEXEMEGEN());
IF .LEXL<LEFT> EQL LINEND THEN ERR0(.LEXNAM[IDENTIFIER]); !NO EXPRESSION FOUND
%[1043]% STK[SP_.LSP+1]_LOGEXPRESSION();
![1072] %[1043]% IF .CONSECOPS THEN WARNLEX( E148<0,0>); ! Issue consec ops warning
%[1043]% RETURN .STK[.SP]
END;
GLOBAL ROUTINE LOGEXPRESSION=
BEGIN
%
ROUTINE IS CALLED BY THE ACTION ROUTINE EXPRESSION
TO PARSE AN ARBITRARY FORTRAN EXPRESSION
THE ROUTINE IS AN OPERATOR PRECEDENCE METHOD, THE PRECEDENCE OF THE
OPERATORS IS GIVEN IN THE TABLE PRECEDENCE IN THIS FILE
ROUTINE IS RECURSIVE
THE OPERATORS ** AND UNARY MINUS ARE HANDLED AS SPECIAL CASES IN THIS ROUTINE AND THE ROUTINES IT CALLS
%
MACRO BLDTREE(OPRATOR)=
BEGIN
LABEL BLDTR;
BLDTR: BEGIN
LOCAL OPR;
REGISTER BASE R2:T1:T2;
OPR_.OPRATOR;
NAME _ EXPTAB; !GENERATE AN EXPRESSION NODE
T1 _ NEWENTRY();
T1[ARG2PTR]_R2 _ .STAK[.STP]; STP _ .STP-1;
IF .OPR<LEFT> EQL LOGICALNOT
THEN
BEGIN
EXTERNAL FATLEX,E132,TPCDMY; ![1056]
%MAKE SURE THIS ISN'T A BINARY .NOT.%
IF .STP NEQ 0
THEN
IF .STAK[.STP-1]<LEFT> LEQ LASTLEX
THEN
IF NOT OPER( .STAK[.STP-1]<LEFT>)
THEN RETURN FATLEX(E132<0,0>);
T1[OPRCLS] _ NEGNOT; T1[OPERSP]_ NOTOP;
IF .R2[OPRCLS] EQL DATAOPR THEN T1[A2VALFLG] _1
ELSE (R2[PARENT] _ .T1;
IF .R2[FNCALLSFLG] THEN T1[FNCALLSFLG] _ 1;
);
!NOT NODES SHOULD ALWAYS BE OF TYPE LOGICAL
T1[VALTYPE] _ LOGICAL;
T1[ARG1PTR] _ 0;
![1056] If a node of double size sits below a .NOT. node (shudder),
![1056] we need to insert an intervening type conversion node so that
![1056] register allocation does not use odd registers for dp and
![1056] complex numbers.
%[1056]% IF .R2[DBLFLG] THEN T1[ARG2PTR]_TPCDMY(.T1,.R2);
LEAVE BLDTR WITH .T1;
END;
T1[ARG1PTR] _ .STAK[STP_.STP-1];
CASE .OPR<LEFT>-6 OF SET
%RELATION% (T1[OPRCLS]_RELATIONAL;T1[OPERSP]_.OPR<RIGHT>);
%NOT% (T1[OPRCLS]_NEGNOT;T1[OPERSP]_NOTOP);
%AND% (T1[OPRCLS]_BOOLEAN;T1[OPERSP]_ANDOP);
%OR% (T1[OPRCLS]_BOOLEAN;T1[OPERSP]_OROP);
%MATCH% (T1[OPRCLS]_BOOLEAN;T1[OPERSP]_ IF .OPR<RIGHT> EQL 1 THEN EQVOP ELSE XOROP);
%POWER% (T1[OPRCLS]_ARITHMETIC;T1[OPERSP]_EXPONOP);
0;
0;
0;
0;
0;
0;
%MINUS% (T1[OPRCLS]_ARITHMETIC;T1[OPERSP]_SUBOP);
%DIVIDE% (T1[OPRCLS]_ARITHMETIC;T1[OPERSP]_DIVOP);
%PLUS% (T1[OPRCLS]_ARITHMETIC;T1[OPERSP]_ADDOP);
%TIMES% (T1[OPRCLS]_ARITHMETIC;T1[OPERSP]_MULOP)
TES;
R2 _ .T1; EXPRTYPER(.T1); !SAVING EXPRESSION PTR
!EXPRTYPER BUILDS A TYPE CONVERSION NODE IF NECESSARY
T1_.R2; !RESTORING PTR
R2_.T1[ARG2PTR]; T2_.T1[ARG1PTR]; !RESTORING PTRS
IF .R2[OPRCLS] EQL DATAOPR THEN T1[A2VALFLG]_1
ELSE (R2[PARENT]_.T1;IF .R2[FNCALLSFLG] THEN T1[FNCALLSFLG] _1;);
IF .T2[OPRCLS] EQL DATAOPR THEN T1[A1VALFLG]_1
ELSE (T2[PARENT]_.T1; IF .T2[FNCALLSFLG] THEN T1[FNCALLSFLG] _ 1;);
.T1
END
END$; !OF MACRO BLDTREE
LOCAL STAK[14], STP; !STACK AND STACK PTR
REGISTER BASE R1;
EXTERNAL EXPRTYPER,PRIMITIVE,STK;
EXTERNAL POOL;
LABEL EXPR1,EXPR2;
!
!CHECK FOR STACK OVERFLOW
!
IF .SREG<RIGHT> GEQ (POOL<0,0>-50)<0,0> THEN RETURN FATLEX(E90<0,0>);
!
STP _ -1; !INITIALIZE THE STACK PTR
%[1043]% ARITHOPSEEN _ 0; ! No arithmetic operators seen yet
WHILE 1 DO
BEGIN
EXPR1:
IF .LEXL<LEFT> NEQ LOGICALNOT
THEN
BEGIN
IF (STAK[STP_.STP+1] _ PRIMITIVE()) LSS 0 THEN RETURN -1; !GET AN OPERAND OR OPERATOR
!RETURN ON ERROR (-1)
EXPR2: WHILE 1 DO
BEGIN
IF NOT OPER(.LEXL<LEFT>)
THEN (IF .STP LEQ 0 THEN RETURN .STAK[.STP];)
ELSE (
IF .STP LEQ 0 THEN LEAVE EXPR2;
IF .PRECEDENCE[.LEXL<LEFT>] GTR .PRECEDENCE[.STAK[.STP-1]<LEFT>]
THEN LEAVE EXPR2; !LEAVE TO STACK THE OPERATOR
);
!HERE IF NOT OPERATOR AND STACK PTR GTR 0
!OR
!IF OPERATOR PRECEDENCE LEQ PREVIOUS OPERATOR'S
STAK[.STP] _ BLDTREE(STAK[.STP-1]); !BUILD A TREE NODE
END; !OF WHILE 1 DO
END; !OF IF LEXL NEQ NOTOP
!
!HERE IF STACKING HIGER PRECEDENCE OPERATOR OR
!NOT OP SEEN OR FIRST OPERATOR SEEN
!
STAK[STP_.STP+1] _ .LEXL;
%[1043]% ARITHOPSEEN _ .ARITHOPFLAGS[ .LEXL<LEFT>]; ! Indicate arith op seen
LEXL _ LEXEMEGEN();
%[626]% FLGREG<FELFLG> _ 0; !ARRAYREFS OR FNS W/O ARG LISTS NO LONGER LEGAL
END; !OF WHILE 1 DO
!EXIT FROM THIS LOOP IS BY RETURN FROM INSIDE THE LOOP
END; !OF LOGEXPRESSION
GLOBAL ROUTINE REFERENCE=
BEGIN
%
ROUTINE PARSES A VARIABLE OR FUNCTION REFERENCE
INCOMING LEXEME IS ALREADY AVAILABLE IN LEXL AND MUST BE AN IDENTIFIER
ROUTINE THEN PROCEEDS TO CHECK FOR ARRAY OR FUNCTION REFEERENCE
AND IF A LEFT PAREN IS SEEN THEN THE LST OF SUBSCRIPTS OR ARGUMENTS IS SCANNED
ROUTINE RETURNS A PTR TO A VARIABLE OR FUNCTION REFERENCE NODE
%
EXTERNAL NAMREF,NAMSET;
LOCAL BASE IDPTR;
EXTERNAL MAKLIBFUN; !MAKES A LIBRARY FUNCTION CALL NODE
EXTERNAL ARRXPN,SRCHLIB,ASTATFUN,CORMAN,COPYLIST,SAVSPACE,PROGNAME,TBLSEARCH,CNVNODE;
%[1004]% LOCAL VAL;
%[1004]% EXTERNAL LIBFUNTAB,LIBATTRIBUTES;
%[1004]% MAP LIBATTSTR LIBATTRIBUTES;
REGISTER BASE T1:T2;
MACRO ERR65(X)= RETURN FATLEX ( X, E65<0,0> ) $;
MACRO ERR47(X)= RETURN FATLEX( X, E47<0,0> ) $;
IF .LEXL<LEFT> NEQ IDENTIFIER
THEN ERR0(.LEXNAM[IDENTIFIER]);
IDPTR _ .LEXL<RIGHT>; !PTR TO IDENTIFIER
LEXL _ LEXEMEGEN(); !NEXT LEXEME TO LOOK FOR "("
IF .LEXL<LEFT> EQL LPAREN
THEN
BEGIN !ARRAY REFERENCE OR FUNCTION REFERENCE
LOCAL LSP; LSP _.SP; !SAV THE STK PTR FO SYNTAX
DO BEGIN !WHILE REFERENCE FOLLOWED BY ","
LEXL _ LEXEMEGEN();
IF .IDPTR[OPRSP1] NEQ ARRAYNM1 !IF NOT ARRAY THEN FUNCTION CALL
THEN FLGREG<FELFLG> _ 1; !SET FLG FOR CHECKING ARGS IN ARGLIST OF FUNCTION
IF (.LEXL<LEFT> NEQ DOLLAR) AND (.LEXL<LEFT> NEQ ANDSGN)
THEN (IF ( STK[SP _ .SP+1] _ LOGEXPRESSION()) LSS 0 THEN RETURN -1)
ELSE
BEGIN
!LABEL ARGS ARE ILLEGAL IN FUNCTION OR ARRAY REF'S
RETURN FATLEX(E83<0,0>);
END;
END WHILE .LEXL<LEFT> EQL COMMA;
IF .LEXL<LEFT> NEQ RPAREN THEN ERR0(.LEXNAM[RPAREN]);
FLGREG<FELFLG> _ 0; !TURN OFF FELFLG FOR NEXT FUNCTION CALL
COPYLIST(.LSP); !COPY LIST FROM STK TO FREE CORE
INCR ARG FROM .STK[.SP] TO .STK[.SP]+.STK[.SP]<LEFT> DO
BEGIN MAP BASE ARG;
MACRO ARGPTR=0,0,FULL$, ARGFLG=0,0,LEFT$;
LOCAL BASE R2;
R2 _ .ARG[ARGPTR];
IF .R2[OPRCLS] EQL DATAOPR
THEN ARG[P1AVALFLG] _ 1
ELSE ARG[P1AVALFLG] _ 0;
END; !OF INCR ARG
!
!NOW SEE IF FUNCTION CALL OR ARRAY REF TO MAKE PROPER NODE TYPE
!
LEXL _ LEXEMEGEN(); !FOR POSSIBLE RETURN TO CALLING ROUTINE
IF .IDPTR[OPRSP1] NEQ ARRAYNM1
THEN !IDENTIFIER IS FUNCTION NAME
BEGIN
LABEL LIBCHK;
LOCAL BASE ARGPT: FNEXPR;
REGISTER R2; !FOR PTR TO FUNTION ARG LIST
FLGREG<BTTMSTFL> _ 0; !TURN OFF BOTTOMOST ROUTINE FLAG
!CHECK FOR RECURSIVE STATEMENT FUNCTION
IF (.IDPTR EQL .ASTATFUN) THEN ERR47(IDPTR[IDSYMBOL]);
NAME<LEFT> _ .STK[.SP]<LEFT>+3;
R2 _ CORMAN(); !CORE FOR FUNCTION ARGLIST
!
!NOW MOVE THE ARGLIST TO A BLOCK POINTED TO BY R2
!BEGINNING AT WORD .R2+2 OF THE BLOCK
!
NAME _ EXPTAB; ENTRY[0] _ .IDPTR; ENTRY[1] _ .R2;
FNEXPR_NEWENTRY(); !MAKE AN EXPREESION NODE FOR FNCALL
FNEXPR[VALTYPE] _ .IDPTR[VALTYPE]; FNEXPR[OPRCLS] _ FNCALL;
(.R2+1)<RIGHT> _ .STK[.SP]<LEFT>+1; !NUMBER OF ARGS
!PREPARE TO MOVE ARGLIST TO NEW AREA
T1 _ .STK[.SP]; T2 _ .R2+2; !FROM T1 TO T2
DECR I FROM .STK[.SP]<LEFT> TO 0 DO
BEGIN
(.T2)[.I] _ ARGPT _ @(.T1)[.I];
IF .ARGPT<LEFT> EQL 0 !IS ARG FUNCTION OR EXPRESION
THEN ARGPT[PARENT] _ .FNEXPR;
END;
!
! NOW IF FUNCTION CALL IS TO LIBRARY CALL SPECIAL PROCESSING ROUTINE
! IN MODULE GNRCFN
!
LIBCHK:BEGIN
IF NOT .IDPTR[IDATTRIBUT(INEXTSGN)] AND NOT .IDPTR[IDATTRIBUT(DUMMY)]
THEN (
LOCAL LIBPTR;
IF (LIBPTR_ SRCHLIB(.IDPTR)) NEQ -1
THEN (
MAKLIBFUN(.LIBPTR,.FNEXPR); !MAKE THE LIB FUNCTION CALL NODE
LEAVE LIBCHK;
)
);
FNEXPR[OPERSP] _ NONLIBARY;
%NOTE POSSIBLE "SET" FOR NON-LIBRARY FUNCTIONS%
DECR I FROM .STK[.SP]<LEFT> TO 0 DO
BEGIN
ARGPT _ @(.T2)[.I];
IF .ARGPT[OPRCLS] EQL DATAOPR
THEN ( IF .ARGPT[OPRSP1] EQL ARRAYNM1 OR .ARGPT[OPRSP1] EQL VARIABL1
THEN NAMSET(VARYREF, .ARGPT) )
ELSE IF .ARGPT[OPRCLS] EQL ARRAYREF
THEN NAMSET( ARRAYNM1, .ARGPT[ARG1PTR]);
END;
END; %LIBCHK%
!
NAMREF(FNNAME1, .FNEXPR[ARG1PTR]) ; !RECORD THE REFERENCE
SAVSPACE(.STK[.SP]<LEFT>,.STK[.SP]); !SAVE THE ARGLIST SPACE
IDPTR _ .FNEXPR;
END
ELSE
BEGIN
% ARRAY NAME%
NAMREF(ARRAYNM1, .IDPTR); !RECORD THE REFERENCE
IDPTR _ ARRXPN(.IDPTR,.STK[.SP]);
END;
SP _ .LSP; !RESTORING STK PTR TO ORIGINAL TO AVOID RECURSION PROBLEMS
END
ELSE
!CHECK USE O NAME WITHOUT SUBSCRIPTS OR ARGS
IF .IDPTR[PARENLSTFLG]
THEN
BEGIN !ARRAYNAME OR FUNCTION NAME W/O ARGS OR SUBSCRIPTS
IF NOT .FLGREG<FELFLG>
OR ( .IDPTR[OPRSP1] EQL FNNAME1
AND NOT ( .IDPTR[IDATTRIBUT(INEXTERN)] OR .IDPTR[IDATTRIBUT(INEXTSGN)] )
)
%[626]% OR OPER(.LEXL<LEFT>) !CAN'T BE EMBEDDED IN AN EXPRESSION
THEN !ERRONEOUS USE OF IDENTIFIER
BEGIN
RETURN NAMREF(VARIABL1, .IDPTR) ! THIS WILL PRODUCE ERROR MESSAGE
END
ELSE IF .IDPTR[OPRSP1] EQL FNNAME1
THEN
BEGIN
% GET .ED NAME IF THIS IS A LIBRARY FUNCTION - NOT IN EXTERNAL WITH */& %
IF NOT .IDPTR[IDATTRIBUT(INEXTSGN)]
THEN
%[1004]% IF ( VAL_SRCHLIB( .IDPTR) ) NEQ -1
THEN
BEGIN
%[761]% EXTERNAL NAME,ENTRY,DOTTEDNAMES,GDOTTEDNAMES,LIBFUNTAB,TBLSEARCH;
NAME _ IDTAB;
%[1004]% VAL_.VAL - LIBFUNTAB<0,0>; ! Get offset into table
%[1004]% IF .GFLOAT AND .LIBATTRIBUTES[.VAL,ATTRESTYPE] EQL DOUBLPREC
%[1004]% THEN ENTRY[0] _ .GDOTTEDNAMES[ .VAL]
%[1004]% ELSE ENTRY[0] _ .DOTTEDNAMES[ .VAL];
IDPTR _ TBLSEARCH()
END;
NAMREF(FNNAME1, .IDPTR)
END
ELSE NAMREF(ARRAYNM1, .IDPTR)
END
ELSE NAMREF( VARIABL1, .IDPTR ); !RECORD REFERENCE
RETURN .IDPTR !RETURN HERE ONLY
END; !OF REFERENCE
GLOBAL ROUTINE PRIMITIVE=
BEGIN
%
PARSES A PRIMITIVE OF AN EXPRESSION
THESE ARE:
[$ OR * OR &]LABEL
[+,-]CONSTANT OR LITERAL
[+,-]REFERENCE (ARRAY OR FUNCTION)
A**B
(REAL,REAL) COMPLEX CONSTANT
(EXPRESSION)
AND LEAVES NEXT LEXEME AVAILABLE WHEN FINISHED
%
LOCAL BASE NEGATNODE;
LOCAL BASE REALPART:IMAGPART;
MACRO MAKEREAL(X)=
BEGIN
![761] KTYPCG for /GFLOATING type conversions
%[761]% EXTERNAL KTYPCB,KTYPCG,CNVNODE;
C1H_0;
C1L_X;
COPRIX _ KKTPCNVIX(REAL2,FROMINT);
CNSTCM();
END$;
MACRO DNEG(X)=
BEGIN
C1H _ X[CONST1]; !HIGH ORDER
C1L _ X[CONST2]; !LOW ORDER
%[761]% COPRIX _ KDNEGB;
CNSTCM(); !CONVERT TO NEG
MAKECNST(REAL,.C2H,.C2L)
END$;
![761] KGFRL for converting GFLOATING DP to SP
%[761]% EXTERNAL CNSTCM,C1H,C1L,C2H,C2L,COPRIX,KDPRL,KGFRL,KDNEGB,CNVNODE;
EXTERNAL EXPRTYPER,TBLSEARCH;
LABEL PRIM1;
NEGATNODE _ 0;
WHILE 1 DO
BEGIN !SCAN UNTIL NO LEADING + OR MINUS
IF .LEXL<LEFT> EQL MINUS
THEN( IF .NEGATNODE EQL 0 THEN NEGATNODE _ MAKENEGAT ELSE NEGATNODE _ 0;
LEXL _ LEXEMEGEN();
)
ELSE IF .LEXL<LEFT> EQL PLUS
THEN LEXL _ LEXEMEGEN()
ELSE EXITLOOP;
%[626]% FLGREG<FELFLG> _ 0; !CALL FOO(+ARRAY) ISN'T LEGAL
![1043] Flag an error if 2nd arith op in a row, else mark operator seen
%[1043]% IF .ARITHOPSEEN NEQ 0 THEN CONSECOPS _ -1 ELSE ARITHOPSEEN _ -1;
END; !OF WHILE 1 DO
%[1043]% ARITHOPSEEN _ 0; ! Next token cannot be an arith operator
PRIM1:
IF .LEXL<LEFT> EQL LPAREN
THEN !PRENTHESIZED EXPRESSION OR COMPLEX CONSTANT
BEGIN
%[626]% FLGREG<FELFLG> _ 0; !CALL FOO((ARRAY)+1) ILLEGAL
LEXL _ LEXEMEGEN();
IF (REALPART _ LOGEXPRESSION()) LSS 0 THEN RETURN -1; !RECURSE RETURN IF ERROR
IF .LEXL<LEFT> EQL COMMA
THEN !EXPECTING A COMPLEX CONSTANT
BEGIN
EXTERNAL FATLEX,E127;
LOCAL NEGSIGN;
NEGSIGN _ 0;
%1122% IF .REALPART[OPRCLS] EQL NEGNOT
THEN !MUST BE A NEGATIVE CONSTANT
(
REALPART _ .REALPART[ARG2PTR];
IF .REALPART[OPERSP] NEQ CONSTANT THEN ERR0(.LEXNAM[RPAREN]);
NEGSIGN _ -1;
)
ELSE IF .REALPART[OPERSP] NEQ CONSTANT
%1122% OR .REALPART[OPRCLS] NEQ DATAOPR
THEN ERR0(.LEXNAM[RPAREN]);
%DON'T ALLOW ELEMENTS OF COMPLEX CONSTANTS TO BE
COMPLEX CONSTANTS %
IF .REALPART[VALTYPE] EQL COMPLEX THEN RETURN FATLEX(E127<0,0>);
IF .REALPART[VALTYPE] EQL INTEGER THEN REALPART _ ( MAKEREAL(.REALPART[CONST2]);MAKECNST(REAL,.C2H,.C2L));
IF .NEGSIGN NEQ 0 THEN REALPART _DNEG(.REALPART);
!NOW CONVERT TO SINGLE PRECISION
IF .REALPART[VALTYPE] NEQ OCTAL
THEN
BEGIN
C1H _ .REALPART[CONST1]; C1L _ .REALPART[CONST2];
![761] Convert DP to SP based on /GFLOATING
%[761]% IF .GFLOAT
%[761]% THEN COPRIX_KGFRL
%[761]% ELSE COPRIX_KDPRL;
CNSTCM(); !CONVERSION ROUTINE
REALPART _ .C2H;
END
ELSE REALPART _ .REALPART[CONST2]; !GET THE OCTAL BITS
NEGSIGN _ 0;
LEXL _ LEXEMEGEN();
IF .LEXL<LEFT> EQL PLUS
THEN LEXL _ LEXEMEGEN()
ELSE IF .LEXL<LEFT> EQL MINUS
THEN( NEGSIGN _ -1; LEXL _ LEXEMEGEN());
IF .LEXL<LEFT> NEQ CONSTLEX THEN ERR0(.LEXNAM[CONSTLEX]);
IMAGPART _ .LEXL<RIGHT>;
IF .IMAGPART[VALTYPE] EQL INTEGER THEN IMAGPART _ (MAKEREAL(.IMAGPART[CONST2]); MAKECNST(REAL,.C2H,.C2L));
IF .NEGSIGN NEQ 0 THEN IMAGPART_ DNEG(.IMAGPART);
!NOW CONVERT TO SINGLE PRECISION
IF .IMAGPART[VALTYPE] NEQ OCTAL
THEN
BEGIN
C1H _ .IMAGPART[CONST1]; C1L _ .IMAGPART[CONST2];
![761] Convert DP to SP based on /GFLOATING
%[761]% IF .GFLOAT
%[761]% THEN COPRIX_KGFRL
%[761]% ELSE COPRIX_KDPRL;
CNSTCM(); !CONVERSION ROUTINE
IMAGPART _ .C2H;
END
ELSE IMAGPART _ .IMAGPART[CONST2]; !GET THE OCTAL BITS
REALPART _ MAKECNST(COMPLEX,.REALPART,.IMAGPART);
LEXL _ LEXEMEGEN();
END !OF IF COMMA
ELSE IF .REALPART[OPRCLS] NEQ DATAOPR THEN REALPART[PARENFLG] _ 1;
IF .LEXL<LEFT> NEQ RPAREN THEN ERR0(.LEXNAM[RPAREN]);
LEXL_ LEXEMEGEN(); !THIS IS TO LOOK AHEAD FOR EXPONENT OPERATOR
LEAVE PRIM1;
END !OF IF ... LPAREN
ELSE !NOT A PARENTHESIZED EXPRESSION
BEGIN
IF .LEXL<LEFT> EQL CONSTLEX OR .LEXL<LEFT> EQL LITSTRING
THEN (REALPART _ .LEXL<RIGHT>; LEXL _ LEXEMEGEN())
ELSE
IF ( REALPART _ REFERENCE()) LSS 0 THEN RETURN .VREG; !VARIABLE OR FUNCTION REFERENCE
!REFERENCE WILL RETURN WITH NEXT LEXEME IN LEXL
END; !OF PRIM1:
!
!HERE NOW TO CHECK FOR ** OPERATOR AND SPECIAL PRIMITIVE
!REALPART CONTAINS EITHER
! 1. PTR TO CONSTANT NODE OR
! 2. PTR TO EXPRESSION NODE OR
! 3. PTR TO VARIABLE OR FUNCTION REFERENCE
!
IF .LEXL<LEFT> EQL POWER
THEN
BEGIN !MAKE AN EXPONENT NODE
LOCAL BASE EXPON;REGISTER BASE T1;
%[1043]% ARITHOPSEEN _ -1; ! Flag arith op seen
%[626]% FLGREG<FELFLG> _ 0; !CALL FOO(3**ARRAY) ILLEGAL
NAME _ EXPTAB; EXPON_NEWENTRY();
EXPON[OPRCLS]_ARITHMETIC; EXPON[OPERSP]_EXPONOP;
EXPON[ARG1PTR] _ .REALPART; !BASE
!NOW CHECK FOR SONS BEING DATAOPR OR NOT AND SET PARENT POINTERS APPROPRIATELY
LEXL _ LEXEMEGEN();
IF (REALPART _ PRIMITIVE()) LSS 0 THEN RETURN -1; !RECURSE TO GET A**B**C = A**(B**C)
EXPON[ARG2PTR]_.REALPART;
EXPRTYPER(.EXPON); !CHECK FOR TYPE CONVERSIONS
REALPART _ .EXPON[ARG1PTR]; !CHECK SONS NOW
IF .REALPART[OPRCLS] EQL DATAOPR
THEN EXPON[A1VALFLG]_1
ELSE ( REALPART[PARENT]_.EXPON;
IF .REALPART[FNCALLSFLG] THEN EXPON[FNCALLSFLG]_1;
);
REALPART _ .EXPON[ARG2PTR]; !CHECK SON AGAIN
IF .REALPART[OPRCLS] EQL DATAOPR
THEN EXPON[A2VALFLG]_1
ELSE ( REALPART[PARENT]_.EXPON;
IF .REALPART[FNCALLSFLG] THEN EXPON[FNCALLSFLG]_1;
);
REALPART _ .EXPON;
END;
IF .NEGATNODE NEQ 0
THEN(
NEGATNODE[ARG2PTR]_.REALPART;
NEGATNODE[ARG1PTR] _ 0;
IF .REALPART[OPRCLS] EQL DATAOPR
THEN
BEGIN
% NEGATE CONSTANTS NOW%
IF .REALPART[OPERSP] EQL CONSTANT
THEN RETURN NEGCNST ( REALPART );
NEGATNODE[A2VALFLG]_1
END
ELSE ( REALPART[PARENT]_.NEGATNODE;
IF .REALPART[FNCALLSFLG] THEN NEGATNODE[FNCALLSFLG]_1;
);
NEGATNODE[VALTYPE]_ (IF .REALPART[VALTYPE] EQL CONTROL THEN LOGICAL ELSE .REALPART[VALTYPE]);
RETURN .NEGATNODE
)
ELSE RETURN .REALPART;
END; !0F ROUTINE PRIMITIVE
END
ELUDOM