Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0078/comp/cgob.mac
There are 2 other files named cgob.mac in the archive. Click here to see a list.
00100 SUBTTL Written by Olof Bjorner Sep-73
00200
00300 COMMENT ;
00400
00500 Version: 4A [10,174,321,327]
00600
00700 Purpose: To compile an assignment statement
00800
00900 Contents: The subroutine CGAS which is called externally
01000 The following local subroutines:
01100 CGASTX for text assignment
01200 CGASFP for assignment to formal parameter
01300 CGASRI for assignment to remote identifier
01400 CGASAR for assignment to array element
01500 CGASEQ which compares two ZID-nodes and skips if they represent
01600 the same identifier
01700 ;
01800
01900 SEARCH SIMMAC,SIMMC2,SIMMCR
02000 sall
02100 CTITLE CGOB
02200 TWOSEG
02300 RELOC 400K
02400 MACINIT
02500 CGINIT
02600
02700 INTERN CGAS
02800
02900 EXTERN YZHBXC,YCGACT,YLXIAC
03000 EXTERN YO2ADI,YOPCOD,YTAC ;LOW SEGMENT VARIABLES
03100 edit(321)
03200 EXTERN YFORSI ;[321]
03300 EXTERN O2GA,O2GR,O2GI,O2AD ;Output routines
03400 EXTERN O2CF,O2DF,O2GF,O2GW,O2GWD,O2IV
03500 EXTERN CGRD,CGG4,CGR4,CGMO,CGMO1,CGVA,CGAD,CADS,CGAA
03600 EXTERN CGCA,CGCC,CGCO,CGG2,CGG3,CGIM,CGIM1,CGLO,CGLO1,CGR2,CGR3
03700 edit(174)
03800 EXTERN ORTXCH ;[174]
03900 ;Code generation routines
04000
04100 OPDEF EXITAS [GOTO CGASEXIT]
04200 OPDEF IFNOTSAME [PUSHJ XPDP,CGASEQ]
04300
04400 DSW CGSWAP,0,35,XL2 ;This switch is on if RHS can be compiled first
04500
04600 IFN QDEBUG,<
04700 CGASER: ASCIZ/ILL ZNNCOD DURING ASSIGNMENT COMPILATION/>
00100 SUBTTL CGAS Assignment compilation
00200
00300 comment ;
00400
00500 Method: 1. Inspect lhs(left hand side node), if it is text assignment
00600 execute CGASTX and exit.
00700 2. If rhs(right hand side node) is a
00800 memory operand or else if there are no side-effects
00900 in rhs or lhs go to step 4.
01000 3. Compile lhs before rhs and exit.
01100 4. If rhs is of kind simple go to step 6.
01200 5. Compile rhs before lhs and exit.
01300 6. Look for optimizable cases and compile special code if
01400 possible else go to step 5.
01500
01600 Entry conditions:
01700 X1 points at lhs
01800 X2 points at rhs.
01900 XCUR points at their parent
02000
02100 Exit conditions:
02200 @YTAC contains value of rhs.
02300 ;
02400
02500 CGAS:
02600 PROC
02700 SAVE <X6,X7,XP1,XP2,XL1,XL2,XV1,XV2,XCUR>
02800 LD XP1,X1 ;NOW XP1 -> LHS AND XP2 -> RHS
02900
03000 ;Take care of text assignment first
03100 LF X6,ZNNTYP(XP1)
03200 IF ;Text assignment
03300 CAIE X6,QTEXT
03400 GOTO FALSE
03500 LF ,ZNSGEN(XCUR)
03600 CAIN %BECOM
03700 GOTO TRUE
03800 edit(321)
03900 CAIE %FORSI ;[321]
04000 GOTO .+4 ;[321]
04100 MOVN YFORSI ;[321]
04200 CAIN 1 ;[321]
04300 GOTO TRUE ;[321]
04400 edit(174)
04500 ;[174] WHENNOT X2,ZCN
04600 ;[174] GOTO FALSE
04700 ;[174] HRRZ OFFSET(ZCNVAL)(X2)
04800 ;[174] SKIPE
04900 L X0,X2 ;[174]
05000 EXEC ORTXCH ;[174]
05100 GOTO FALSE ;[174]
05200 ERROR2 51,TEXT STRING AFTER DENOTES
05300 GOTO FALSE
05400 THEN EXEC CGASTX
05500 EXITAS
05600 FI
05700
05800 ;Then check if RHS can be compiled first
05900 IFMEMO ;LHS memory opnd?
06000 GOTO CGASSW ;Yes!
06100 IFOFF ZNSSEF(XCUR) ;side-effects in RHS or LHS?
06200 GOTO CGASSW ;No!
06300 WHEN (XP2,ZCN) ; RHS constant
06400 GOTO CGASSW
06500
00100 ;Must compile LHS first!
00200 SETOFA CGSWAP ;Flag LHS first
00300 COMPAD ;Compute address to LHS
00400 L XL1,@YTAC
00500 AOS YTAC
00600 LF XV1,ZNNCOD(XP1)
00700 IF CAIN XV1,QCODAR
00800 GOTO TRUE
00900 CAIE XV1,QCODCA
01000 GOTO FALSE
01100 LF ,ZNNTYP(XP1)
01200 CAIE QREF
01300 GOTO FALSE
01400 THEN
01500 AOS YTAC ; LHS is two words
01600 FI
01700 EXCH XP1,XP2
01800 COMPVAL ;Compute value of RHS
01900 EXCH XP1,XP2
02000 L XV2,@YTAC ;Save value of ac that holds RHS value
02100
02200 ;Now check type of LHS. Valid types are remote identifier,
02300 ;array element and formal parameter and they are tried in that order
02400 IF ;Remote identifier
02500 CAIE XV1,QCODRA
02600 GOTO FALSE
02700 THEN L XV1,XL1 ;Load base address ac
02800 EXEC CGASRI
02900 ELSE
03000 IF ;Array element
03100 CAIE XV1,QCODAR
03200 GOTO FALSE
03300 THEN L XV1,XL1 ;Load array address ac to XV1
03400 ADDI XL1,1
03500 ;Ac with offset already in XL1
03600 EXEC CGASAR
03700 ELSE
03800 IF ;Formal parameter
03900 CAIE XV1,QCODCA
04000 GOTO FALSE
04100 THEN L XV1,XL1 ;Load dynamic address ac
04200 EXEC CGASFP
04300 ASSERT<
04400 ELSE ;Illegal result descriptor!
04500 RFAIL CGASER
04600 >
04700 FI FI FI
04800 SOS YTAC
04900
05000 CGASEXIT: ;Common termination point for CGAS
05100 RETURN
05200
00100 ;This code takes care of the case when RHS can be compiled first
00200
00300 CGASSW:
00400 ;Now XP1 -> LHS and XP2 -> RHS
00500 SETONA CGSWAP ;Flag RHS first
00600 LF ,ZIDZHE(XP1)
00700 IF ;We have a ZHE for this ZQU
00800 JUMPN FALSE
00900 THEN ;It is an assignment to a procedure identifier
01000 EXCH XP1,XP2
01100 COMPVAL
01200 L X2,[MOVEM 2(XCB)]
01300 L X1,XP1
01400 IFLONG
01500 OP X2,(DMOVEM (XCB))
01600 L X2
01700 ADD YCGACT
01800 ; Check if assignment is in procedure block at outer level
01900 LF X1,ZIDZQU(XP2)
02000 LF X1,ZQUZB(X1)
02100 LF X1,ZHEDLV(X1)
02200 L X2,YZHBXC
02300 LF X2,ZHEDLV(X2)
02400 IF ;Not declared at same block level
02500 CAMN X1,X2
02600 GOTO FALSE
02700 THEN ;Cannot use XCB as base
02800 L X2, ; Save store instr.
02900 L X1 ; Display block offset
03000 edit(327)
03100 ST X1,YLXIAC ;[327] Remember dlv (as in O2AD)
03200 OP (L XIAC,(XCB))
03300 GENABS
03400 ADD X2,[Z (XIAC-XCB)]
03500 L X2 ; Restore modified instr
03600 FI
03700 GENABS
03800 EXITAS
03900 FI
04000 IF WHENNOT XP1,ZNS
04100 GOTO TRUE ;LHS terminal
04200 WHENNOT XP2,ZNS
04300 GOTO TRUE ;RHS terminal
04400 LF ,ZNSGEN(XP2)
04500 CAIN %THIS
04600 GOTO FALSE ; Do not try to optimize
04700 THEN
04800 IF IFON ZNSSEF(XCUR)
04900 GOTO FALSE ; No optimization
05000 THEN
05100 GOTO CGASOP
05200 FI
05300 FI
05400 EXCH XP1,XP2 ;XP1 -> RHS now
05500
05600 L1():! ;Return here from CGASOP when we could not optimize
05700 COMPVAL ;Compile RHS
05800 STACK YTAC
05900 L XV2,@YTAC ;Load ac with result
06000 AOS YTAC
06100 HLRZ X1,XV2
06200 IFLONG
06300 AOS YTAC
06400 EXCH XP1,XP2 ;XP1 -> LHS
06500 COMPAD ;Compute address to LHS
06600
06700 ;Type of left hand side may now be either of
06800 ;local identifier, remote identifier, array element
06900 ;or formal parameter and they are tried in that order.
07000
07100 LF X6,ZNNCOD(XP1)
07200 IF ;Local identifier
07300 CAIE X6,QCODVA
07400 GOTO FALSE
07500 THEN LF X1,ZNNZQU(XP1)
07600 UNSTK YTAC
07700 GETAD
07800 OPZ X2,(ST)
07900 HLRZ X1,XV2
08000 IFLONG
08100 OPZ X2,(STD)
08200 ST X2,YOPCOD
08300 GENOP
08400 ELSE
08500 L XV1,@YTAC ;Load ac with target address
08600 ;(array, base or dynamic)
08700 IF ;Remote identifier
08800 CAIE X6,QCODRA
08900 GOTO FALSE
09000 THEN EXEC CGASRI
09100 ELSE
09200 IF ;Array element
09300 CAIE X6,QCODAR
09400 GOTO FALSE
09500 THEN L XL1,XV1 ;Ac with offset
09600 ADDI XL1,1
09700 EXEC CGASAR
09800 ELSE
09900 IF ;Formal parameter
10000 CAIE X6,QCODCA
10100 GOTO FALSE
10200 THEN EXEC CGASFP
10300 ASSERT<
10400 ELSE ;ERROR!
10500 RFAIL CGASER
10600 >
10700 FI FI FI
10800 UNSTK YTAC
10900 FI
11000 EXITAS
11100
00100 comment /
00200
00300 This code takes care of certain optimizable cases:
00400 (The value of Xtop is found in YTAC)
00500 1. LHS is BOOLEAN: b:=TRUE is compiled as SETOB Xtop,b(XCB)
00600 b:=FALSE " SETZB Xtop,b(XCB)
00700 2. LHS is REAL: a:=a " L Xtop,a(XCB)
00800 a:=0 " SETZB Xtop,a(XCB)
00900 a:=a+<EXPR.> " FADRB Xtop,a(XCB)
01000 a:=a*<EXPR.> " FMPRB Xtop,a(XCB)
01100 3. LHS is INTEGER: i:=i " L Xtop,i(XCB)
01200 i:=0 " SETZB Xtop,i(XCB)
01300 i:=-1 " SETOB Xtop,i(XCB)
01400 i:=i+1 " AOS Xtop,i(XCB)
01500 i:=i-1 " SOS Xtop,i(XCB)
01600 i:=i+<EXPR.> " ADDB Xtop,i(XCB)
01700 i:=i*<EXPR.> " IMULB Xtop,i(XCB)
01800 /
01900
02000 CGASOP:
02100 LF XL1,ZNNTYP(XP1)
02200 EXCH XP1,XP2 ;XP1 -> RHS
02300
02400 IF CONST
02500 GOTO FALSE
02600 CAIN XL1,QTEXT
02700 GOTO FALSE ; Constant optimization not appl. to NOTEXT
02800 THEN
02900 LF X0,ZCNVAL(XP1)
03000 CAME X0,[-1]
03100 JUMPN X0,L1 ;Compile as usual if not const. 0 or -1
03200 OPZ XL1,(SETOB)
03300 CAIN X0,0
03400 OPZ XL1,(SETZB) ;IF NOT b
03500
03600 L3():! ;This code is used for all optimizable cases
03700 EXCH XP1,XP2 ;XP1 -> LHS
03800 IF WHENNOT XP1,ZID
03900 GOTO FALSE
04000 THEN
04100 LF X1,ZIDZQU(XP1)
04200 GETAD ;Address to simple variable
04300 ST XL1,YOPCOD
04400 GENOP
04500 ELSE
04600 AOS YTAC
04700 AOS YTAC
04800 COMPAD
04900 HRRZ X0,@YTAC
05000 LF X1,ZNNCOD(XP1)
05100 CAIN X1,QCODAR
05200 AOS ; This saves a L Xtop,Xtop+1 instruction
05300 ; in array accesses
05400 L X1,YTAC
05500 DPB [INDEXFIELD XL1]
05600 EXEC CGAA
05700 HLLZ XL1
05800 ADD YCGACT
05900 GENABS
06000 FI
06100 EXITAS
06200 FI
00100 ;Now see if LHS is integer or real
00200
00300 CAIL XL1,QINTEGER
00400 CAILE XL1,QREAL
00500 GOTO L1
00600
00700 IF IFNOTSAME
00800 GOTO FALSE ;No it was not
00900 THEN
01000 OPZ XL1,(L)
01100 GOTO L3
01200 FI
01300 IFMEMOP
01400 GOTO L1 ;RHS memory operand
01500
01600 ;Here if RHS is an expression
01700 LF XV1,ZNSZNO(XP1)
01800 LI XV2,2(XV1)
01900
02000 ;Now XP1 -> RHS
02100 ; XP2 -> LHS
02200 ; XV1 -> first opnd
02300 ; XV2 -> last node
02400 ; XL1 contains type of LHS (integer or real)
00100
00200 ;Now see if first node <=> LHS
00300 EXCH XP1,XV1 ;XP1 -> First node XP2=>LHS
00400 IF
00500 CONST
00600 GOTO FALSE
00700 THEN
00800 EXCH XP1,XV1 ;XP1 -> RHS
00900 GOTO L1
01000 FI
01100 IF
01200 IFNOTSAME
01300 GOTO FALSE
01400 THEN
01500 ;SEE IF LAST NODE IS A CONSTANT = 1
01600 EXCH XP1,XV2 ;XP1 -> LAST OPERAND
01700 ;XV2 -> FIRST -"-
01800 IF
01900 CONST
02000 GOTO FALSE
02100 THEN
02200 LF X6,ZCNVAL(XP1)
02300 IF
02400 CAIE X6,1
02500 GOTO FALSE
02600 CAIE XL1,QINTEGER
02700 GOTO FALSE
02800 THEN
02900 ;SEE IF IT IS I:=I+1; OR I:=I-1;
03000 EXCH XP1,XV1 ;XP1 -> RHS
03100 ;XV1 -> LAST OPERAND
03200 LF X6,ZNSGEN(XP1)
03300 IF
03400 CAIE X6,%PLUS
03500 GOTO FALSE
03600 THEN
03700 OPZ XL1,(AOS)
03800 ELSE
03900 IF
04000 CAIE X6,%MINUS
04100 GOTO FALSE
04200 THEN
04300 OPZ XL1,(SOS)
04400 ELSE
04500 GOTO L1
04600 FI
04700 FI
04800 GOTO L3 ;FIND ADDRESS TO LHS
04900 FI
05000 FI
05100 EXCH XV1,XV2 ;XV1 -> FIRST OPERAND
05200 EXCH XP1,XV2 ;XP1 -> RHS
05300 GOTO L4 ;XV2 -> LAST OPERAND
05400 FI
05500
05600
05700 ;NOW SEE IF LAST NODE <=> LHS
05800 EXCH XP1,XV2 ;XP1 -> LAST OPERAND
05900 ;XV2 -> FIRST -"-
06000 ;XV1 -> RHS
06100 IF
06200 CONST
06300 GOTO FALSE
06400 THEN
06500 EXCH XP1,XV1 ;XP1 -> RHS
06600 GOTO L1
06700 FI
06800 IF
06900 IFNOTSAME
07000 GOTO FALSE
07100 THEN
07200 ;SEE IF IT IS X:=X+<EXP> OR X:=X*<EXP>
07300 ; WHERE X COULD BE INTEGER OR REAL
07400
07500 EXCH XP1,XV1 ;XP1 -> RHS
07600 ;XV1 -> LAST OPERAND
07700 L4(): LF X6,ZNSGEN(XP1)
07800 IF
07900 CAIE X6,%PLUS
08000 GOTO FALSE
08100 THEN
08200 IF
08300 CAIE XL1,QINTEGER
08400 GOTO FALSE
08500 THEN
08600 OPZ XL1,(ADDB)
08700 ELSE
08800 OPZ XL1,(FADRB)
08900 FI
09000 ELSE
09100 IF
09200 CAIE X6,%MULT
09300 GOTO FALSE
09400 THEN
09500 IF
09600 CAIE XL1,QINTEGER
09700 GOTO FALSE
09800 THEN
09900 OPZ XL1,(IMULB)
10000 ELSE
10100 OPZ XL1,(FMPRB)
10200 FI
10300 ELSE
10400 GOTO L1
10500 FI
10600 FI
10700 EXCH XP1,XV2 ;XP1 -> FIRST OR LAST OPERAND
10800 ;XV2 -> RHS
10900 COMPVAL ;COMPILE EXPRESSION
11000 GOTO L3 ;FIND ADDRESS TO LHS
11100 FI
11200 EXCH XP1,XV1 ;XP1 -> RHS
11300 ;XV1 -> LAST OPERAND
11400 ;XV2 -> FIRST -"-
11500 GOTO L1 ;COMPILE AS USUAL
11600 EPROC
00100 SUBTTL CGASTX - Text assignment
00200
00300 comment ;
00400 Purpose: To compile code for text assignment.
00500 The following code is generated:
00600
00700 LI XSAC+1,@YTAC
00800 PUSHJ XPDP,TXVA
00900
01000 Before the execution of these statements Xtop
01100 and Xtop+2 contain the values of the text
01200 expressions in the LHS and RHS respectively.
01300 [10] Check if LHS is a text procedure identifier
01400 and do not use COMPVAL in this case to compile
01500 LHS to @YTAC.
01600 ;
01700
01800 CGASTX:
01900 edit(10) ;[10] Check if LHS is a procedure identifier
02000 LF ,ZIDZHE(XP1)
02100 IF ;There was a ZHE for this ZQU
02200 JUMPN FALSE
02300 THEN ;Assignment to procedure id.
02400 ;Fetch the text variable from the procedure block
02500 HRLM XP1,@YTAC ;Fix the accumulator table entry
02600 L X2,[DMOVE 2(XCB)]
02700 L X1,XP1
02800 L X2
02900 ADD YCGACT
03000 ; Check if assignment is at outer level in procedure block
03100 LF X1,ZIDZQU(XP1)
03200 LF X1,ZQUZB(X1)
03300 LF X1,ZHEDLV(X1)
03400 L X2,YZHBXC ;ZHB for current XCB
03500 LF X2,ZHEDLV(X2)
03600 IF ;Not at XCB level
03700 CAMN X1,X2
03800 GOTO FALSE
03900 THEN ;Cannot use XCB for reference to the proc id
04000 L X2, ; Save store instr.
04100 L X1 ; Display block offset
04200 ST X1,YLXIAC ;[327] Remember dlv as in O2AD
04300 ;[327] Could be used in RHS.
04400 OP (L XIAC,(XCB))
04500 GENABS
04600 ADD X2,[Z (XIAC-XCB)]
04700 L X2 ; Restore modified instr
04800 FI
04900 GENABS
05000 ELSE
05100 COMPVAL ;Compute value of LHS
05200 FI
05300 ;[10[ End of check for procedure id.
05400 EXCH XP1,XP2
05500 AOS YTAC
05600 AOS YTAC
05700 COMPVAL ;Compute value of RHS
05800 SOS YTAC
05900 SOS YTAC
06000 OP (LI XSAC+1,)
06100 HRR @YTAC
06200 GENABS ;LI XSAC+1,@YTAC
06300 GPUSHJ TXVA ;EXEC TXVA
06400 ;[327] SETZM YLXIAC ;Already done by GPUSHJ macro
06500 RETURN
00100 SUBTTL CGASRI - Remote identifier
00200
00300 comment /
00400 Purpose: To compile code for remote assignment
00500 Entry conditions:
00600 XP1 -> LHS
00700 XP2 -> RHS
00800 XV1 contains base address ac number
00900 XV2 contains ac number of RHS value
01000 Generated code:
01100 (D)MOVEM @XV2,ZQUIND(@XV1)
01200 ST(D) @XV2,@XV1 ;Only when LHS is compiled first
01300 /
01400
01500 CGASRI:
01600 OP XL1,(MOVEM)
01700 L X1,XP2
01800 IFLONG
01900 OP XL1,(STD) ;Double word result
02000 LF X1,ZNNZNO(XP1) ;Fetch ZQUIND
02100 STEP X1,ZID
02200 LF X1,ZIDZQU(X1)
02300 L XL1
02400 HRR OFFSET(ZQUIND)(X1) ;Offset to RH
02500 DPB XV1,[INDEXFIELD]
02600 DPB XV2,[ACFIELD]
02700 GENABS
02800 IFONA CGSWAP
02900 RET ;If RHS compiled first
03000 L X1,YLINK
03100 SKIPN (X1)
03200 RET ; If not multiple assignment
03300 L XL1
03400 DPB XV2,[ACFIELD]
03500 HRR XV1
03600 GENABS
03700 RETURN
00100 SUBTTL CGASAR - Array element assignment
00200
00300 comment /
00400 Purpose: To compile code for assignment to array element
00500 Entry conditions:
00600 XP1 -> LHS
00700 XP2 -> RHS
00800 XV1 contains array address ac number
00900 XL1 contains offset to base
01000 XV2 contains ac number of value of RHS
01100 Generated code:
01200 ADD @XL1,OFFSET(ZARBAD)(@XV1)
01300 (D)MOVEM @XV2,@XL1
01400 (D)MOVEM @XV2,@XV1 ;Only if LHS compiled first
01500 /
01600
01700 CGASAR:
01800 L [ADD OFFSET(ZARBAD)]
01900 DPB XV1,[INDEXFIELD]
02000 DPB XL1,[ACFIELD]
02100 GENABS ;ADD-INSTR.
02200 OPZ X2,(MOVEM)
02300 L X1,XP2
02400 IFLONG
02500 OPZ X2,(DMOVEM)
02600 L X2
02700 DPB XL1,[INDEXFIELD]
02800 DPB XV2,[ACFIELD]
02900 GENABS ;STORE-INSTR.
03000 IFONA CGSWAP
03100 RET ;If RHS compiled first
03200 L X1,YLINK
03300 SKIPN (X1)
03400 RET ; If not multiple assignment
03500 L X2 ; DMOVEM or MOVEM
03600 DPB XV2,[ACFIELD]
03700 HRR XV1
03800 GENABS ;LOAD-INSTRUCTION
03900 RETURN
00100 SUBTTL CGASFP - Formal parameter assignment
00200
00300 comment /
00400 Purpose: To compile code for assignment to formal parameter
00500 Entry condition:
00600 XP1 -> LHS
00700 XV1 contains dynamic address ac number
00800 XV2 contains number of ac holding RHS value
00900 Generated code:
01000 HLLZ p(XVB) ;Load left half of first formal location
01100 PUSHJ XPDP,PHFS
01200 XWD @XV2,@XV1
01300 (D)MOVE @XV1,@XV2 ;Only when LHS is compiled first
01400 /
01500
01600 CGASFP:
01700 LF XP2,ZIDZQU(XP1)
01800 L X1,XP2
01900 GETAD
02000 LI X0
02100 DPB [ACFIELD YO2ADI]
02200 OP (HLLZ)
02300 ST YOPCOD
02400 GENOP ;HLLZ instr.
02500 GPUSHJ PHFS ;PUSHJ instr
02600 HRL XV2
02700 HRR XV1
02800 GENABS ;XWD
02900 IFONA CGSWAP
03000 RET ;If RHS compiled first
03100 ; Check if in multiple assignment
03200 L X2,YLINK
03300 SKIPN (X2)
03400 RET ; Not multiple assignment
03500 OPZ X2,(MOVE)
03600 L X1,XP2
03700 IFLONG
03800 OPZ X2,(DMOVE)
03900 L X2
04000 DPB XV1,[ACFIELD]
04100 HRR XV2
04200 GENABS
04300 RETURN
00100 SUBTTL CGASEQ Compare expression nodes
00200
00300 comment ;
00400 Purpose: To compare the expressions that are represented
00500 by two expression nodes and return with skip if
00600 they are identical
00700 Entry condition:
00800 XP1 and XP2 should point at two expression nodes.
00900 ;
01000
01100 CGASEQ: L 1(XP1)
01200 CAME 1(XP2) ;Compare second words
01300 RET ;Not equal
01400 n==0 ;Stack size
01500 IF WHENNOT XP1,ZNS
01600 GOTO TRUE
01700 LF ,ZNSGEN(XP1)
01800 CAIE %THIS
01900 GOTO FALSE
02000 THEN ; Terminal nodes
02100 L (XP1)
02200 XOR (XP2)
02300 TLZN 577777 ; Compare first halfwords
02400 AOS -n(XPDP)
02500 RET
02600 ELSE ; Non-terminal nodes, compare recursively
02700 STACK XP1
02800 STACK XP2
02900 n==2
03000 LF XP1,ZNSZNO(XP1)
03100 LF XP2,ZNSZNO(XP2)
03200 LOOP
03300 EXEC CGASEQ
03400 GOTO NOTEQUAL
03500 AS
03600 IFON ZNOLST(XP1)
03700 GOTO FALSE ;That was last node
03800 STEP XP1,ZNS
03900 STEP XP2,ZNS
04000 GOTO TRUE
04100 SA
04200 ; EQUAL
04300 AOS -n(XPDP)
04400 NOTEQUAL:UNSTK XP2
04500 UNSTK XP1
04600 n==0
04700 RET
04800 FI
04900 PURGE n
05000
05100 LIT
05200 END