Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
COMMENT VALID 00023 PAGES VERSION 17(17)
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 HISTORY
C00009 00003 Binary Operators
C00012 00004
C00022 00005 Constant Binary Operators ----- Gtargs
C00025 00006 Unary Operators
C00029 00007 Exponentiation Code!
C00041 00008 Strings -- Concatenation
C00047 00009 Substring, Length, Lop
C00052 00010 Point, Ldb, Ildb, Dpb, etc.
C00059 00011 Swap Operator.
C00066 00012 Store Operator
C00073 00013 Booleans -- Description
C00077 00014 Variables
C00081 00015 Arith TO Relop
C00084 00016 Relational Operators
C00095 00017 Connectives, Negation
C00099 00018 Constant Connectives
C00102 00019 Gbol -- Discussion
C00106 00020 Gbol
C00115 00021 If-Generators
C00122 00022
C00124 00023 BE to P Coercion
C00127 ENDMK
C;
COMMENT HISTORY
AUTHOR,REASON
021 002100000021 ;
COMMENT
VERSION 17(17) 2-21-75 BY rht BUG #UB# inac negat should not turn jumpn into jumpe
VERSION 17(16) 9-19-74 BY JFR INSTALL BAIL
VERSION 17(15) 9-19-74
VERSION 17(14) 7-17-74 BY RHT BUG #ST# ALLSTO IN STIF
VERSION 17(14) 9-19-74
VERSION 17(13) 4-10-74 BY JRL BUG #RT# BOOLEAN DEMORGANIZER GLUBBED UP
VERSION 17(12) 1-27-74 BY JRL BUG #QS# (CMU =A3=) COPY NEGAT BIT CORRECTLY
VERSION 17(11) 1-11-74 BY JRL RHT'S ASH STUFF
VERSION 17(10) 12-9-73 BY JRL BUG #PT# GIVE ERROR MESSAGE WHEN COMPARING ARITH VS ITEM EXPRESSION
VERSION 17(9) 12-9-73
VERSION 17(8) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17(7) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17(6) 11-4-73 BY JRL BUG #OX# SWAP BAD NEWS WITH ? ITEMVAR PARAMETERS
VERSION 17(5) 11-4-73 BY RHT BUG #OV# BOTH CNST TEST SHOULD BE BEFORE INAC TEST
VERSION 17(4) 8-19-73 BY RHT BUG #NV# R. SMITH HAD CALLED CONINS W/O THE CNST BIT ON!
VERSION 17(3) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSE
VERSION 17(2) 7-26-73 BY RHT REALLY IS VERSION 17 NOW
VERSION 17(1) 7-26-73
VERSION 16-2(52) 6-29-73 BY JRL BUG #MZ# REAL^(-2) NOT AN ERROR
VERSION 16-2(51) 5-15-73 BY JRL BUG #MK# EXIF2 CALLED MARK WITHOUT ZEROING SBITS IN CASE OF STRING
VERSION 16-2(50) 3-20-73 BY JRL ADD SET,LIST ERROR CHECKING TO SWAP
VERSION 16-2(49) 3-13-73 BY JRL REMOVE REFERENCES TO GAG,SLS,WOM,NODIS
VERSION 16-2(48) 11-27-72 BY JRL NEW ERROR MESSAGE FOR BOOLEAN EXPRESSION IN SWAP
VERSION 16-2(46) 11-21-72 BY JRL BUG #KI# ONLY DO DUMMY GETAC FOR IBP
VERSION 16-2(45) 11-21-72 BY JRL GIVE ERR MSG INTEGER RAISED TO NEG INT POWER
VERSION 16-2(44) 11-17-72 BY JRL BUG #KE# IBP OF FIXARR ARGUMENT
VERSION 16-2(43) 10-23-72 BY JRL COMPILE ITEM COMPARISONS INLINE
VERSION 16-2(42) 9-27-72 BY RHT BUG #JG# REG B CLOBBERMENT CAUSED IDPB TO BECOME IBP IN BYPS
VERSION 16-2(41) 9-26-72 BY JRL BUG #JE# SAVE UNARY OP DISPATCH NUMBER AROUND CALL TO CONV
VERSION 16-2(40) 7-22-72 BY DCS BUG #IR# ILDB(A[I]) FIXED
VERSION 16-2(39) 7-9-72 BY RHT BUG #IM# FIX TRUE OR I BUG
VERSION 16-2(38) 7-5-72 BY JRL BUG #IJ# STRING ITEM NOT STRING IN STORE
VERSION 16-2(37) 6-30-72 BY DCS BUG #IA# BETTER AC PROTECTION IN STORE OPERATOR
VERSION 16-2(36) 5-22-72 BY JRL FIX BUG #HL# DESTRUCTION OF LEAP BITS WITHIN ITEM EXPRESSION STORES
VERSION 16-2(35) 5-17-72 BY DCS BUG #HK# FIX TEMP BUG IN SWPR (SWAP OPERATOR)
VERSION 16-2(34) 5-14-72 BY DCS BUG #HG# CONSTANT BOOLEAN FIX TO MAKE /H WORK
VERSION 15-2(14-33) 4-9-72 ALL SORTS OF THINGS
VERSION 15-2(10) 2-25-72 BY JRL FIX SVSTR
VERSION 15-2(9) 2-6-72 BY DCS BUG #GO# IN BINARY ARITH OR BOOL OPS, EXCH IF BOTH STTEMP
VERSION 15-2(8) 2-6-72 BY DCS BUG #FW# MAKE LOP(I) WORK RIGHT
VERSION 15-2(7) 2-5-72 BY DCS BUG #GJ# ADD LISTING CONTROL STUFF
VERSION 15-2(6) 2-5-72 BY DCS BUG #GI# CONCATENATION OF NUMBERS DONE BETTER
VERSION 15-2(5) 1-10-72 BY DCS BUG #FZ# MAKE X WORK
VERSION 15-2(4) 1-3-72 BY DCS ADD EXPOP1, TWID21 EXECS FOR BE'S AS PRIMARIES
VERSION 15-2(3) 1-2-72 BY DCS ADD CHKCON ROUTINE TO ASSURE CONSTANT EXPR
VERSION 15-2(2) 1-2-72 BY DCS ADD EXPOP FOR NEW EX-BEX CLEANLINESS
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
;
SUBTTL Binary Operators
BEGIN ARITH
LSTON (EXPRS)
DSCR TIMDIV, PLUSM, MAXMIN
PRO TIMDIV, PLUSM, MAXMIN
DES Binary operator generators.
The generators for + - XOR EQV & * / DIV MOD MAX MIN are all
located in the environs. This is perhaps the easiest piece
of code to understand at the outset. Everything is well
behaved. Syntactic contexts are:
T @TD P SG drarrow T SG @TD TIMDIV
E @PM T SG drarrow E SG @PM PLUSM
TABCONDATA (BINARY OPERATOR OPCODE TABLES)
PMTAB: ADD (<FADR>) ;TABLE OF OPCODES FOR +,-,XOR,EQV
SUB (<FSBR(1)>)(1)
EQV 2,
AND 2,
IOR 2,
XOR 2,
LPMTAB: DADD (<DFAD>) ;TABLE OF OPCODES FOR LONG +,-,XOR,EQV
DSUB (<DFSB(1)>)(1)
EQV 2,
AND 2,
IOR 2,
XOR 2,
TDTAB: IMUL (<FMPR>) ; *
IDIV (<FDVR (1)>) (1) ; %
FDVR 4,(1) ; /
LSH 3,(1) ; LSH
ROT 3,(1) ; ROT
IDIV (3) ; DIV
IDIV (7) ; MOD
;;%##%
ASH 3,(1) ; ASH
LTDTAB: DMUL (<DFMP>) ; *
DDIV (<DFDV (1)>) (1) ; %
DFDV 14,(1) ; /
LSHC 3,(1) ; LSH
ROTC 3,(1) ; ROT
PRINTX ASSUMING NO DMOD OR DDIV
IDIV (3) ; DIV
IDIV (7) ; MOD
ASHC 3,(1) ; ASH
MXMNTB: CAMGE (<CAMGE>) ; MAX (COMMUTATIVE,
CAMLE (<CAMLE>) ; MIN TYPELESS)
MXMNT2: CAML (<CAMGE>) ;2ND, 3RD INSTR FOR LONG MAX, MIN
CAMG (<CAMLE>)
COMMENT
The table contains entries for the fixed point and floating
point operations. The index field is used to indicate:
Bit 1 -- order important
Bit 2 -- must be fixed point operation.
Bit 4 -- for MOD only -- means mark the second AC with the results.
Bit 10 -- for MOD(DMOD) only -- mark the third AC with the double result
And the AC field is used to indicate
Bit 1 -- needs immediate operand.
Bit 2 -- NO type conversions necessary **** ???
Bit 4 -- INSIST on REAL arguments.
Bit 10 -- INSIST on LONG arguments
ENDDATA
;THESE GENERATORS ARE ENTERED FROM THE PARSER.
;REGISTER "B" HAS AN INDEX IN IT -- THIS IS THE INDEX OF THE
;CLASS MEMBER (OPERATOR) WHICH IS INVOLVED IN THE CALL.
^MAXMIN: MOVE C,MXMNTB(B) ;MAX OR MIN
MOVEM C,OPCODE
PUSH P,B ;REMEMBER WHICH
PUSHJ P,GTARGS
TRNN TBITS,DBLPRC
TRNE TBITS2,DBLPRC
JRST .+2 ;ONE IS LONG
JRST PLSMD1 ;BOTH SINGLE
MOVE C,[CAMN (<CAMN>)]
MOVEM C,OPCODE ;FIRST INSTR OF DOULBE MAX,MIN
JRST PLSMD2
;;%##%
^TIMDIV: CAIL B,10 ;IS THIS THE STRING OPERATOR & ?
JRST CONCAT ;YES
MOVE C,TDTAB(B) ;PICK UP OPERATOR
TLZ FF,FFTEMP ;WE CAME FROM TIMDIV
JRST PLSMDO
^PLUSM: MOVE C,PMTAB(B) ;FOR PLUS OR MINUS , ETC.
TLO FF,FFTEMP ;WE CAME FROM PLUSM
PLSMDO: MOVEM C,OPCODE ;SAVE THE OPCODE
;;#GO# DCS (1-4) IF BOTH ARGS ARE STRING TEMPS, FETCHING THE
;; #GO# SECOND OPERAND WILL WORK WONDERS
PUSHJ P,GTARGS ;ARG1'S SEM TO PNT, ETC., ARG2'S TO PNT2, ETC.
;;#GO# (1) FETCHED ARG2 TO AC IF BOTH STRING TEMPS, TO GET ORDER RIGHT
TRNE TBITS,DBLPRC ;CHECK FIRST FOR DOUBLE
PUSHJ P,[TPCDBL:
TLNE FF,FFTEMP ;WHERE DID WE FETCH INSTR?
SKIPA C,LPMTAB(B) ;IT WAS A PMTAB
MOVE C,LTDTAB(B) ;NO, IT WAS TDTAB
MOVEM C,OPCODE
POPJ P,]
PLSMD1: HRRI FF,ARITH!POSIT!BITS2 ;JUST INSIST ON ARITH ARG IF
TLNE C,100 ;NO CONVERSIONS TO DO?
JRST TPGO
TRNE TBITS2,DBLPRC ;NOW CHECK SECOND FOR DOUBLE INSTR
PUSHJ P,TPCDBL
PLSMD2: TLNE C,200 ;DO WE REQUIRE REAL ARGS.?
TLOA B,FLOTNG ;YES
TLO B,INTEGR ;NO, MAKE IT FIXED
TLNE C,400 ;DBLPRC REQUIRED?
TLO B,DBLPRC ;YES
HRRI FF,INSIST!POSIT!BITS2 ;GOING TO INSIST FROM NOW ON.
TLNE C,602 ;ARE TYPES PRE-DETERMINED?
JRST TPGO ;YES.
TPCHK:
TRNN TBITS,DBLPRC ;NOW CHECK PRECISION
TRNE TBITS2,DBLPRC
TLO B,DBLPRC
TRNN TBITS,FLOTNG
TRNE TBITS2,FLOTNG ;IF EITHER ARE FLOTING, DO
JRST [MOVSS OPCODE ;SOME IMPORTANT THINGS.
TLC B,FLOTNG!INTEGR ;ON FLOTNG, OFF INTEGR
JRST .+1]
TPGO: HLRZ B,B ;FETCH TYPE
GENMOV (CONV) ;TYPE IS ALREADY IN B.
TRO FF,EXCHIN!EXCHOUT
GENMOV (CONV) ;NOW REPEAT FOR THIS ONE.
;NOW SEE WHICH ARGUMENTS ARE WHERE (IN ACCUMULATORS,
;OR WHATEVER. TRY TO DO THINGS IN THE BEST ORDER.
TLZ FF,FFTEMP ;A RANDOM FLAG
HLLZ A,OPCODE ;GET THE OPCODE BITS.
;;#OV# RHT (11-4-73) CHECK CONSTANTS BEFORE INAC
TLNE TBITS2,CNST ;A CONSTANT ?
TLNN TBITS,CNST ;FIRST ARG ALSO A CONSTANT?
JRST .+2
JRST ALLCON ;YES -- COMPUTE IT NOW
TLNE SBITS2,INAC ;IS SECOND ARG IN AC?
TLNE SBITS,INAC ;IS FIRST ARG IN AC?
JRST OKORD ;WE ARE IN LUCK.
;; GET HERE IF SECOND ARG INAC & FIRST ARG INAC
;;#OV# CONSTANT CHECK USED TO BE HERE
BADORD: TLNE A,1 ;IS ORDER IMPORTANT?
JRST F4WIN ;YESS -- TOUGH LUCK.
REVORD: EXCHOP ;INTERCHANGE ARGUMENTS FINALLY
OKORD: TLZ A,777 ;MASK OFF HORSESHIT BITS.
HRRI FF,POSIT!BITS2 ;WE NEED TO GET THE FIRST ARG IN AC.
CAMN A,[IDIV ] ;IS THIS THE SPECIAL OPCODE?
TRO FF,DBL ;WE NEED A DOUBLE AC.
GENMOV (GET) ;CALL THE WIZARD.
;AC NUMBER IS RETURNED IN D.
TRNN TBITS2,FLOTNG ;IF ARG IS FLOATING OR
TLNN TBITS2,CNST ;NOT CONSTANT, THEN NO HOPE OF OPTIMIZING
JRST NOOOP ;JUST EMIT THE INST.
HLRZ A,OPCODE ;GET OPCODE
CAIL A,220000 ;IMUL
CAILE A,230001 ;IDIV.-- THIS EXCLUDES MOD AND DIV
;THE REASON IS THAT -1 MOD 2 SHOULD BE 0.
;BUT THE ASH WOULD MAKE -1 MOD 2 BE -1
JRST NOOOP ;NO OPTIMIZATION.
MOVE B,$VAL(PNT2) ;PICK UP VALUE
PUSHJ P,PWR2 ;IS IT A POWER OF TWO?
JRST NOOOP ;NO OPTIMIZATION.
CAIE A,(<IMUL>) ;A DIVIDE?
MOVNS C ;YES .......
ASHGO: MOVE A,[ASH USADDR+NORLC]
JRST EMGOX ;EMIT OPTIMAL INSTRUCTION.
NOOOP:
EMCN: EXCHOP
;;%DU% JFR 1-4-77
;;#YR# JFR 2-2-77
PUSH P,D
HRRI FF,PROTECT ;GET ACCESS TO SECOND OPERAND
HLRZ TEMP,OPCODE
CAIL TEMP,(<CAI>)
IORI FF,ACESS2 ;NEED TO GET AT 2ND WORD FOR MAX,MIN,LAND,EQV,LOR,XOR
PUSHJ P,ACCESS
EXCH D,(P)
HRRI FF,UNPROTECT
PUSHJ P,POST
POP P,D
;;#YR# ^
;;%DU% ^
HLLZ A,OPCODE ;ALL READY TO GO TO EMITER.
TLZ A,737 ;TURN OFF CONTROVERSIAL BITS.
TLZE A,40
JRST [ ;LSH, ASH, ROT (IMMEDIATE OPERAND NEEDED)
PUSH P,A
TLNE TBITS,CNST
JRST [
;;#XW# ! (1/2) JFR 12-12-76 IMMEDIATE OPERAND (SHIFT COUNT) IS INTEGER!
GENMOV (CONV,INSIST,INTEGR)
HRL C,$VAL(PNT) ;CONSTANT SHIFT AMOUNT
POP P,A ;RETRIEVE OPCODE
HRRI A,USADDR!NORLC
JRST EMGOX]
HRLS D ;SAVE CURRENT AC IN LH(D)
;;#XW# ! (2/2) JFR 12-12-76 IMMEDIATE OPERAND (SHIFT COUNT) IS INTEGER!
GENMOV (GET,INDX!POSIT!PROTECT!INSIST,INTEGR) ;SHIFT CNT IS INTEGR
MOVSS D ;GET BACK AC
HRRZS ACKTAB(D) ;UNPROTECT ARG1'S
TRNE TBITS,DBLPRC
HRRZS ACKTAB+1(D) ;UNPROTECT 2ND AC OF LONG
POP P,A ;AND INSTR
HRRI A,USX!NOADDR
JRST .+1]
EMGOX: PUSHJ P,EMITER ;DO THE EMIT. !! AN ARITHMETIC INSTRUCTION !!
EXIT: MOVE A,OPCODE
TLNE A,14 ;IS IT "MOD" OR "DMOD"
JRST [PUSHJ P,CLEARA ;YES -- THIS AC HAS BEEN CHANGED.
ADDI D,1 ;YES--MARK THE SECOND ACCUMULATOR
TLNE A,10 ;IS IT DMOD
ADDI D,1 ;YES
JRST .+1]
MOVS TEMP,A ;IF MAX OR MIN, BOTH HALVES ARE
CAMN TEMP,A ;EQUAL, THIS DETECTS IT
JRST [POP P,B ;MAX OR MIN
MOVEI TEMP,(TEMP) ;OPCODE ONLY
CAIN TEMP,(<CAMN>) ;DOUBLE?
AOJA D,[HLLZ A,MXMNT2(B) ;YES, DO SECOND INSTR
IORI A,FXTWO
PUSHJ P,EMITER
HRLZ A,MXMNT2(B) ;AND 3RD
SUBI D,1
PUSHJ P,EMITER
JRST EXIT1]
EXIT1:
PUSHJ P,CLEARA ;WE'RE GOING TO REPLACE IT
GENMOV (GET,SPAC) ;TEST FAILED, GET OTHER VAL
JRST .+1] ;VERRRY SIMPLE
TLZE FF,FFTEMP ;SHOULD WE MARK NEGATIVE?
TLC SBITS,NEGAT ;JUST FLIP THIS BIT!
TRNE TBITS,DBLPRC
TRNN TBITS2,DBLPRC
JRST .+2 ;NOT BOTH DOUBLE
AOJA D,[TLNN A,100 ;BOTH DOUBLE. WAS IS EQV, AND, IOR, XOR?
SOJA D,.+1 ;NO
HRRI A,FXTWO ;YES, DO SECOND WORD
PUSHJ P,EMITER
SOJA D,.+1]
PUSHJ P,REMOP ;REMOP THE FIRST ARGUMENT,
PUSHJ P,REMOP2 ;AND THE SECOND.
TLZN A,100 ;DID WE SAY "NO CONVERSIONS."?
JRST MARK1 ;NO -- GENMOV(MARK)!; MOVEM PNT,GENRIG+1
GETSEM (3) ;YES -- GET THIS FOR MARKING.
TRNE TBITS,STRING ;IN CASE SOME FUCKER LSHED A STRING
MOVEI TBITS,INTEGR
JRST MARK1 ;GENMOV(MARK) ; MOVEM PNT,GENRIG+1
F4WIN:
CAME A,[SUB (1)] ;IS IT THE SUBTRACT GIVING US TROUBLE?
JRST OKORD ;NO -- LIVE WITH THE ORDER.
TLO FF,FFTEMP ;YES -- INDICATE SIGN SHOULD BE FLIPPED.
JRST REVORD ;GO REVERSE THE OPERANDS.
SUBTTL Constant Binary Operators ----- Gtargs
ALLCON: HLLZ A,OPCODE
HRRI A,$VAL(PNT2) ;ADDRESS OF ARGUMENT.
TLNE A,40 ; NEED IMMEDIATE OPERAND?
JRST [
;;#YD# 2! JFR 1-5-77 IMMEDIATE OPERAND (SHIFT COUNT) IS AN INTEGER
GENMOV (CONV,EXCHIN!EXCHOUT!INSIST,INTEGR)
HLLZ A,OPCODE
HRR A,$VAL(PNT2) ; YES.
JRST .+1]
TLZA A,777
GETC: HLR A,C ;GET THE IMMEDIATE RESULT FROM OPCHK.
MOVE B,$VAL(PNT) ;THE FIRST ARGUMENT
MOVE C,$VAL2(PNT)
JRST .+2
ALCON1: HRRI A,$VAL(PNT) ;THE UNARY ARGUMENT.
TLO A,B*40
MOVEI TEMP,1 ;DETECT SKIPS, FOR THOSE WHO CARE
XCT A ;DO THE OPERATIONS.
MOVEI TEMP,0 ;DIDN'T SKIP
CONRET: MOVEM TBITS,BITS
MOVS A,OPCODE
CAMN A,OPCODE ;MAX OR MIN?
;;#YN# JFR 1-26-77 KEEP STACK RIGHT AND HANDLE DOUBLES
JRST [POP P,A ;YES, GET INDEX
TRNE TBITS,DBLPRC ;LONG?
JRST (TEMP)[ ;YES, 1ST INSTR CAN SKIP
XCT (A)[CAML C,$VAL2(PNT2)
CAMG C,$VAL2(PNT2)]
XCT (A)[CAMGE B,$VAL(PNT2)
CAMLE B,$VAL(PNT2)]
JRST CONRTD ;DMOVE B,$VAL(PNT2)
JRST .+1]
JUMPN TEMP,.+1 ;SKIPPED, VALUE OK
CONRTD: MOVE B,$VAL(PNT2) ;NO SKIP, ANS IS THIS ONE
;;#YN# ^
MOVE C,$VAL2(PNT2)
JRST .+1]
MOVEM B,SCNVAL ;RESULT
MOVEM C,DBLVAL
TRNE A,4 ;A "MOD"
MOVEM C,SCNVAL
TRNE A,4
MOVEM D,DBLVAL
PUSHJ P,CONINS ;MAKE A CONSTANT
JRST PUT1 ;MOVEM PNT,GENRIG+1 ;POPJ P,
;;#GO# DCS 2-6-72 (2-4)
^GTARGS:GETSM2 (1) ;ARG2'S SEMANTICS TO PNT2, TBITS2, SBITS2
GETSEM (3) ;ARG1'S SEMANTICS TO PNT, TBITS, SBITS
TLNE SBITS,STTEMP ;IS FIRST A STRING TEMP?
TLNN SBITS2,STTEMP ;YES, IS SECOND?
POPJ P, ; AT LEAST ONE ISN'T
GENMOV (GET,ARITH!EXCHIN!REM);FETCH 2D SO ORDER WILL BE RIGHT
MOVEI TBITS,INTEGR ;MARK AS AN INTEGR
GENMOV (MARK,EXCHOUT)
POPJ P,
;;#GO# (2)
SUBTTL Unary Operators
DSCR UNARY
PRO UNARY
DES Unary Operators.
This generator is called from the parser with an index
in B which corresponds to the operator seen.
The syntactic contexts are:
@UNOPE P SG drarrow P SG @UNOPE UNARY
^UNARY: MOVE PNT,GENLEF+1 ;GET SEMANTICS OF ARGUMENT.
;; #JE# BY JRL 9-26-72 SAVE DISPATCH INDEX AROUND CALL TO CONV
PUSH P,B
GENMOV (CONV,ARITH!GETD) ;INSIST ON ARITHMETIC TYPE.
POP P,B
;; #JE#
XCT UNTAB(B) ;DISPATCH
UNTAB: JRST UNOT ;UNARY NOT.
JRST UNABS ;ABSOLUTE VALUE
JRST PUT1 ;UNARY PLUS IS ALMOST A NO-OP
JRST UMIN ;UNARY MINUS
UNABS:
TRNE TBITS,DBLPRC
JRST [TLNE TBITS,CNST
JRST [DMOVE B,$VAL(PNT) ;DO DOUBLE ABS OF CONSTANT
SKIPGE B
DMOVN B,B
JRST CONRET]
GENMOV (GET,POSIT) ;NEED INAC
MOVSI A,(<SKIPGE>)
PUSHJ P,UGOO ;RECURSE FOR FIRST INSTR, MARK IT NOW
MOVSI A,(<DMOVN>)
JRST EMITER] ;AND PJRST FOR SECOND INSTR
MOVSI A,(<MOVM>)
JRST UGOO
UNOT:
TRNE TBITS,DBLPRC
JRST [TLNE TBITS,CNST ;DO IT NOW IF CONSTANT
JRST [SETCM B,$VAL(PNT)
SETCM B+1,$VAL2(PNT)
JRST CONRET]
MOVE A,[SETCM POSIT] ;ELSE LATER
PUSH P,PNT ;VERRRY TRICKY
PUSHJ P,UGOO ;RECURSE FOR FIRST INSTR, MARK IT NOW
EXCH PNT,(P) ;PNT_OLD, (P)_NEW TEMPORARY
IORI A,FXTWO ;2ND WORD
ADDI D,1 ;2ND AC
PUSHJ P,EMITER
POP P,PNT ;GET BACK THE MARK'ED TEMPORARY
POPJ P,]
MOVE A,[SETCM POSIT]
UGOO: MOVEM A,OPCODE
TLNE TBITS,CNST ;A CONSTANT?
JRST ALCON1 ;USE ARITHMETIC CONSTANT FOR EXIT.
GETAB: HRRZ D,$ACNO(PNT) ;GET AC NUMBER
;;%DU% JFR 1-4-77
LDB TEMP,[POINT 3,OPCODE,2]
CAIL TEMP,3 ;DETECT SETCM
IORI FF,ACESS2
;;%DU% ^
GENMOV (ACCESS) ;DO ALL GOOD THINGS.
TLNN SBITS,INAC
PUSHJ P,GETAC ;GET A NEW AC IF WE DON'T HAVE ONE.
HLLZ A,OPCODE ;PICK UP OPCODE
PUSHJ P,EMITER ;EMIT A MOVN OR MOVMS
PUSHJ P,REMOP ;REMOP THE OPERAND.
TLZ SBITS,NEGAT ;LEAVE THIS UNFORTUNATE BIT OFF.
JRST MARK1 ;GENMOV (MARK) ; MOVEM PNT,GENRIG+1
UMIN:
TLNN TBITS,CNST ;ONLY THESE DON'T QUALIFY.
TLNN SBITS,INAC ;CAN ONLY BE FOR REG. VARBS.
;I.E. NOT INDEXED VARIABLES.
JRST [
MOVSI A,(<MOVN>)
TRNE TBITS,DBLPRC
TLC A,(<MOVN><DMOVN>)
JRST UGOO]
TLC SBITS,NEGAT ;HO HO
MOVE D,$ACNO(PNT) ;AC IT'S IN
GENMOV (MARK,0) ;MAKE IT A TEMP!
JRST PUT1 ;GO AWAY, RECORDING
BEND ARITH
SUBTTL Exponentiation Code!
BEGIN EXPON
EXTERNAL FLOGS,LOGS ;FIND A BETTER PLACE FOR EXTERNAL DECL
DSCR EXPON
PRO EXPON
DES Exponentiation routines.
R. Smith
ALGORITHM
<exp1>^<exp2> is evaluated at compile time if both
are constants. If both are integers and <exp2> is geq 0, then
this evaluation produces an integer, otherwise a real. Errors
are: 1) 0^0 (default 1), and 2) arithmetic overflow (default
largest integer). Otherwise the routines in GOGOL are called for
the compile-time evaluation.
If <exp2> is a positive integral constant, then a series
of imuls or fmps is compiled inline.
In other cases, the appropriate routine is called, as
below. All routines return reals.
Argument Exponent Run-time routine
----------------------------------------------
INTEGR INTEGR POW
REAL INTEGR FPOW
LONG REAL INTEGR DPOW
any other involving LONG REAL DLOGS
INTEGR REAL LOGS
REAL REAL FLOGS
;;#GO# DCS 2-6-72 (3-4)
^EXPON:PUSHJ P,GTARGS ;SEM'S OF ARGS, 2D TO AC IF BOTH STTEMP
;;#GO# (3)
TLNN TBITS2,CNST ;IF EXPONENT IS CONSTANT
JRST EXRTN1 ;USE ROUTINES
TLNE TBITS,CNST ;AND BASE IS CONSTANT
JRST ALLCN ;THEN EVALUATE NOW
TRNN TBITS2,INTEGR ;IF EXPONENT IS INTEGER, THEN COMPILE IN-LINE
JRST EXRTN1 ;NEED TO CALL RUNTIME ROUTINES.
SKIPGE B,$VAL(PNT2) ;EXPONENT (CONSTANT)
JRST EXRTN1 ; NEGATIVE, CALL SUBROUTINE
MOVE SP,[IMUL USADDR!NORLC]
TRNE TBITS,INTEGR ;ARGUMENT INTEGER?
JRST FXDEX ;YES -- ALL SET.
HRLI SP,(<FMPR>)
TRNE TBITS,DBLPRC
HRLI SP,(<DFMP>)
FXDEX:
PUSHJ P,PWR2 ;IS IT A POWER OF TWO?
JRST NOASH ;NO.
HLRZ SBITS2,C ;SAVE COUNT FROM PWR2
GENMOV (GET,POSIT)
JUMPE SBITS2,EXMRKA ;IF IT WAS ARG ^ 1 ;
ANOMUL: HRL C,D ;THE AC NUMBER.
MOVE A,SP ;THE INSTRUCTION.
PUSHJ P,EMITER
SOJG SBITS2,ANOMUL ;MORE TO GO ?
JRST EXMRKA
NOASH:
SKIPE B,$VAL(PNT2) ;EXPONENT ZERO?
JRST NOASH1 ;NO
PUSH P,TBITS ;TYPE OF RESULT
PUSHJ P,REMOP ;YES, DONT NEED ARGS AT ALL
PUSHJ P,CLEAR
PUSHJ P,REMOP2
MOVEI A,1 ;PREPARE TO RETURN 1.0
PUSHJ P,CREINT
POP P,B ;TYPE OF RESULT
GENMOV (GET,INSIST!GETD)
JRST MARK1
NOASH1:
TRNE TBITS,DBLPRC ;CHECK TYPE OF BASE
TROA FF,DBL ;IS DBLPRC, RESULT WILL BE ALSO, NEEDS DBL AC
TRZ FF,DBL ;SINGLE AC ONLY
PUSHJ P,GETAC ;GET IT
PUSH P,D ;SAVE AC OF RESULT
GENMOV (GET,PROTECT!POSIT) ;GET BASE, PROTECT RESULT AC
HRLI C,(D) ;AC OF BASE
TRNE TBITS,DBLPRC ;IS RESULT LONG?
TLOA PNT,(<DMOVE>) ;YES
TLO PNT,(<MOVE>) ;NO
POWLUP: MOVE A,SP ;INSTRUCTION
TLNE PNT,-1 ;IF IMUL AC1,AC2 NOT DONE YET
HLL A,PNT ;THEN USE MOVE
HRR D,(P) ;AC OF RESULT
TRNE B,1 ;OUTPUT THE IMUL ?
PUSHJ P,EMITER ;IMUL AC1,AC2
TRNE B,1
TLZ PNT,-1 ;DONT 'MOVE' ANYMORE
HLR D,C
ASH B,-1
JUMPE B,POWDUN
MOVE A,SP
PUSHJ P,EMITER ;IMUL AC2,AC2
JRST POWLUP
POWDUN: POP P,D ;AC OF RESULT
PUSHJ P,CLEARA ;IT HAS CHANGED
EXMRK:
EXMRKA: PUSHJ P,REMOP ;REMOP THE FIRST ARGUMENT,
PUSHJ P,CLEAR ;THE AC WITH ARG IN IT HAS CHANGED!
PUSHJ P,REMOP2 ;AND THE SECOND.
JRST MARK1 ;GENMOV(MARK) ; MOVEM PNT,GENRIG+1
;TO EVALUATE THESE WE WILL CALL THE RUNTIME ROUTINES. ALL ERRORS
;(E.G. 0^0) ARE HANDLED PLAUSIBLY IN THOSE ROUTINES
;I^J IS HANDLED HERE IF J>0, AND HAS TYPE INTEGR
ALLCN: TRNE TBITS2,INTEGR ;IF EXPONENT IS INTEGER
TRNN TBITS,INTEGR ;AND BASE AS WELL
JRST EXCC1 ;NO, RETURN A REAL
SKIPGE B,$VAL(PNT2) ;AND EXPONENT IS POSITIVE
JRST EXCC1
MOVE A,$VAL(PNT) ;BASE
JUMPE B,EXPZ ;IF EXPONENT IS ZERO
MOVEI C,1
;;#YA# ! JFR 1-3-77 USED TO BE JRST 2,.+1 , WHICH SET ALL KINDS OF BAD FLAGS
JRST 2,@[.+1] ;CLEAR APR FLAGS
EXPLUP:
TRNE B,1
IMUL C,A
JOV POWOV ;OVERFLOW
ASH B,-1
JUMPE B,RETINT ;DONE
IMUL A,A
JOV POWOV
JRST EXPLUP
POWOV: ERR <ARITHMETIC OVERFLOW IN EVALUATING CONSTANT EXPONENTIATION
AS AN INTEGER, WILL TRY EVALUATION AS REAL.>,1
JRST EXCC1 ;
EXPZ: SKIPN A ;0^0?
ERR <I assume 0^0=1>,1
MOVEI C,1 ;ASSUME HE WANTS 1.0
RETINT: MOVE TBITS,[XWD CNST,INTEGR] ;ASSUME INTEGER CONST
MOVEM TBITS,BITS ;MARK
MOVEM C,SCNVAL ;VALUE GENERATED
PUSHJ P,CONINS
JRST PUT1 ;MOVEM PNT,GENRIG+1 POPJ P,
EXCC1: PUSH P,$VAL(PNT2) ;EXPONENT
PUSH P,$VAL(PNT) ;BASE
;FIRST, TEST BASE
TRNN TBITS,INTEGR ;IS IT AN INTEGER?
JRST RELBAS ;BASE IS REAL
;BASE IS INTEGER, LOOK AT EXPONENT
TRNE TBITS2,DBLPRC
JRST [ ;MAKE BOTH LONG REAL AND EVALUATE
DBLDBL:SUB P,X22 ;GET RID OF VALUES STACKED
PRINTX CHANGE HERE WHEN DLOGS INSTALLED
JRST EXRTN1 ;CANT DO EVALUATION UNTIL DLOGS COMES
IFN 0,<
GENMOV (CONV,INSIST,DBLPRC!FLOTNG) ;BASE
GENMOV (CONV,INSIST!EXCHIN!EXCHOUT,DBLPRC!FLOTNG) ;EXPONEN
PUSH P,$VAL(PNT2) ;EXPONENT
PUSH P,$VAL2(PNT2)
PUSH P,$VAL(PNT) ;BASE
PUSH P,$VAL2(PNT)
PUSHJ P,DLOGS ;EVALUATE
JRST RETDBL>;IFN 0,
]
TRNE TBITS2,INTEGR
PUSHJ P,POW
TRNE TBITS2,FLOTNG
PUSHJ P,LOGS
JRST RETREL ;RETURN A REAL
;BASE IS REAL, LOOK AT EXPONENT
RELBAS:
TRNE TBITS,DBLPRC
JRST [PRINTX AND HERE
JRST DBLDBL ;NEED DPOW
IFN 0,<
TRNN TBITS2,INTEGR ;IS EXPONENT AN INTEGER?
JRST DBLDBL ;NO, MAKE BOTH DOUBLE
PUSH P,$VAL2(PNT) ;YES, PUSH 2ND WORD OF BASE
PUSHJ P,DPOW ;EVALUATE
JRST RETDBL>;IFN 0,
]
TRNE TBITS2,INTEGR
PUSHJ P,FPOW
TRNE TBITS2,FLOTNG
PUSHJ P,FLOGS
RETREL: SKIPA TBITS,[XWD CNST,FLOTNG] ;MARK AS FLOTNG
RETDBL: MOVE TBITS,[CNST,,DBLPRC!FLOTNG] ;MARK AS LONG REAL
MOVEM TBITS,BITS ;FOR CONINS LATER.
MOVEM 1,SCNVAL ;AND THE VALUE GENERATED.
MOVEM 2,DBLVAL
PUSHJ P,CONINS ;WATCH THE MAGIC.
JRST PUT1 ;MOVEM PNT,GENRIG+1 ; POPJ P,
EXRTN1: EXCHOP
EXROUT: ;(PNT)=EXPONENT, (PNT2)=BASE
TRNN TBITS,DBLPRC
TRNE TBITS2,DBLPRC
TRNE TBITS,INTEGR ;AT LEAST 1 LONG. MAKE BOTH LONG
JRST EXROU1 ; UNLESS EXPONENT IS INTEGER
GENMOV (CONV,INSIST,DBLPRC!FLOTNG)
GENMOV (CONV,INSIST!EXCHIN!EXCHOUT!PROTECT!UNPROTECT,DBLPRC!FLOTNG)
EXROU1:
GENMOV (STACK,ARITH) ;STACK THE EXPONENT.
GENMOV (STACK,EXCHIN!ARITH) ;AND THE ARGUMENT.
;NOW (PNT)=BASE, (PNT2)=EXPONENT
TRNE TBITS,DBLPRC ;RESULT IS LONG IFF BASE IS LONG
XPREP2 ;LONG REAL RESULT ALSO USES AC2
XPREP ;IN THIS ORDER TO LEAVE RH(D)=1=RESULT AC
MOVNI A,2
ADDM A,ADEPTH ;TO READJUST STACKS.
TRNE TBITS,DBLPRC
JRST [TRNE TBITS2,INTEGR ;BASE IS DBL. WHAT IS EXP?
JRST [SOS ADEPTH ;IT'S INTEGER
XCALL <DPOW>
EXMRK2: PUSHJ P,REMOP
PUSHJ P,CLEAR
PUSHJ P,REMOP2
MOVEI TBITS,DBLPRC!FLOTNG
JRST MARK1]
ADDM A,ADEPTH ;EXP NOT INTEGER, SO MUST BE DBL
XCALL <DLOGS>
JRST EXMRK2]
TRNN TBITS2,INTEGR ;EXPONENT INTEGER?
JRST LOGSS ;NO
TRNE TBITS,INTEGR
JRST [XCALL <POW>
JRST EXMRK1]
XCALL <FPOW>
JRST EXMRK1
LOGSS: TRNE TBITS,INTEGR
JRST [XCALL <LOGS>
JRST EXMRK1]
XCALL <FLOGS>
EXMRK1: PUSHJ P,REMOP ;REMOP THE FIRST ARG
PUSHJ P,CLEAR ; THE AC WITH ARG IN IT CHANGED
PUSHJ P,REMOP2 ;AND THE SECOND
MOVEI TBITS,FLOTNG ;MARK RESULT AS FLOATING
JRST MARK1 ;GENMOV(MARK)
BEND EXPON
SUBTTL Strings -- Concatenation
BEGIN STRING
DSCR CONCAT
PRO CONCAT
DES Concatenation operator handling.
CONCAT is called from the TIMDIV binary expression generators. It
must stack both arguments, and decide which runtime routine to call
based on the types of the arguments. A very special case is that of
<constant or variable> & <expression>, wherein the 2d argument has
already been stacked -- in this case CAT.RV is called, which assumes
that the top stack element is arg1, the next element is arg2.
The syntactic context:
T1: T @TD P SG drarrow T SG @TD MULDIV meaning CONCAT
;;# # 4-9-72 DCS TOTALLY REVISED TO IMPLEMENT CAT.RV -- SUPERSEDES #GI#
^CONCAT:
MOVEI C,0 ;C indexes the routine name -- CAT to start.
GETSEM (3) ;If both arguments are constant, we'll
GETSM2 (1) ; do the whole thing at compile time.
TLNE TBITS,CNST
TLNN TBITS2,CNST
JRST UNCON
CATBOT: GENMOV (CONV,INSIST!EXCHOUT,STRING)
GENMOV (CONV,INSIST,STRING)
MOVE SP,STPSAV ;We'll just use the CAT routine for
MOVSS POVTAB+6 ; compile-time CAT, since results are
PUSH SP,$PNAME(PNT2) ; the same in any case, and we have no
PUSH SP,$PNAME+1(PNT2); good track record for compile-time
PUSH SP,$PNAME(PNT) ; efficiency anyway.
PUSH SP,$PNAME+1(PNT);Making sure we have an appropriate PDL
MOVE USER,GOGTAB
PUSHJ P,INSET ; necessary so that if first string on
; top of string space we won't touch its
; first word. Otherwise SHASH (when remop
; is called) won't get the right bucket list
PUSHJ P,CAT ; for string operations, and the trap
POP SP,PNAME+1 ; routines will identify it properly,
POP SP,PNAME ; we do the CAT, then insert the result
MOVSS POVTAB+6 ; as a brand new string constant. Then
PUSHJ P,REMOP ; we just clean up and leave.
PUSHJ P,REMOP2
PUSHJ P,STRINS
HRRM PNT,GENRIG+1
POPJ P,
UNCON: TRNN TBITS,STRING ;Bit 1 means arg1 is string (CHRCAT or
TRO C,1 ; CHRCHR), Bit 2 means arg2 is string
TRNN TBITS2,STRING ; (CATCHR or CHRCHR). Both cases are
TRO C,2 ; simple, because at most one string will be
JUMPN C,STACKM ; stacked on RSP, so order is not an issue.
TLNN SBITS,STTEMP ;When arg1 is not stacked yet, but arg2 was
TLNN SBITS2,STTEMP ; stacked during its evaluation, we must
JRST STACKM ; do some extra work
; Both strings, arg1 not stacked and arg2 stacked
MOVEI C,4 ;This code invokes CAT.RV (for ReVerse), which
GENMOV (STACK,0) ; will exchange its arguments or something
PUSHJ P,REMOP2 ; before concatenating, to correct the above
JRST CALLM ; mis-stacking problem.
;;#YC# JFR 1-5-77 INSIST ON STRING OR INTEGER
STACKM:
;; GENMOV (STACK,EXCHOUT) ;One (or both) string, or arg1 stacked, or
;; GENMOV (STACK,0) ; arg2 stacked -- be sure both are stacked.
HRRI FF,EXCHOUT!INSIST
HRRI B,INTEGR ;MAY HAVE TO CONVERT
TRNE TBITS,STRING
TRZ FF,INSIST ;ALREADY STRING, DONT INSIST
PUSHJ P,STACK
HRRI FF,INSIST ;NOW FOR OTHER ARG
HRRI B,INTEGR
TRNE TBITS,STRING
TRZ FF,INSIST
PUSHJ P,STACK
;;#YC# ^
CALLM: XCALL <CAT(C)> ;CAT, CHRCAT, CATCHR, CHRCHR, or CAT.RV
TRZ C,4 ;CAT and CAT.RV have similar DEPTH effects--
MOVE TEMP,[-2
0
0
2](C); Adjust both stacks to account for the
ADDM TEMP,SDEPTH ; difference between the number of words
MOVE TEMP,[0
-1
-1
-2](C); pushed, and the number remaining as
ADDM TEMP,ADEPTH ; a result.
MOVEI TBITS,STRING ;Mark the result an STTEMP, and go away.
PUSHJ P,MARKME
HRRM PNT,GENRIG+1
POPJ P,
;;# #
SUBTTL Substring, Length, Lop
DSCR SVSTR, SUBSTR
PRO SVSTR SUBSTR
DES EXECS for Substring operations
SVSTR saves String Semantics on the LENSTR Qstack. This allows
nested substrings and easy operation for INF, without rummaging
around the PP or GP stacks.
SUBSTR issues substring code, given the two numeric arguments
and the top of LENSTR; TO is differentiated from FOR via B
(parse index)
^SVSTR: HRRZ A,GENLEF+1 ;LH ZERO INDICATES STRING (VERSUS LIST)
QPUSH (LENSTR)
AOS LENCNT
POPJ P,
^SUBSTR:QPOP (LENSTR) ;This was String Semblk, saved for INF
;;#VD ! JFR 9-20-75 SOMEHOW THIS WAS NEVER MISSED
SOS LENCNT
PUSH P,GENLEF+1 ;Use PCALL code in PROCED to call SUBSR (B=5),
MOVEI TEMP,.SUBSR ; or SUBST (4)-- B index from @NXT.
CAIN B,4 ;.SUBST and .SUBSR are addrs of SUBST and SUBSR
MOVEI TEMP,.SUBST ; Semblks in RESTAB -- placed by RTRAN via FOO2
MOVEM TEMP,GENLEF+1 ; request. The GENLEF+... indices are:
PUSHJ P,RDYCAL ; +4 -- String Semblk
MOVEW (<GENLEF+2>,<GENRIG>) ; +3 -- Startchar expression
MOVEW (<GENLEF+1>,<GENLEF+4>) ; +1 -- Endchar or Charcount expression
PUSHJ P,CALARG ;The PROCED routines are used to prevent
POP P,GENLEF+1 ; anomalous behavior, to guarantee correct
PUSHJ P,CALARG ; calling conversions in all cases, and to allow
MOVEW (<GENLEF+1>,<GENLEF+3>); substrings with constant arguments to
PUSHJ P,CALARG ; be done at compile time (FOO2 requests this
JRST ISUCAL ; feature for SUBSR and SUBST).
DSCR SLOP, LLEN
PRO SLOP LLEN LLEN1
DES EXECS to issue code to to LOP(STR) and LENGTH(STR) in line
^SLOP: PUSHJ P,GETAN0
MOVE PNT,GENLEF+1
GENMOV (ACCESS,GETD!INSIST,STRING)
;;#FW# DCS 2-6-72 (1-1) LOP(I) DOESN'T WORK
MOVEM PNT,GENLEF+1 ;STORE RESULT WHERE IT'LL BE LOOKED FOR
;;#FW# (1-1)
MOVE A,[HRRZ LNWORD] ;GET LENGTH FIRST
PUSHJ P,STROP ;LIKE THIS
PUSH P,PCNT ;SAVE THIS ADDRESS FOR FIXUP
HRLI C,0
EMIT (<JUMPE USADDR!NORLC>) ;RETURN 0 IF STRING EMPTY
HRROI C,<<ILDB> -=27 >
EMIT (HRROI USADDR!NORLC) ;GET -1 IN AC.
MOVE TBITS2,[ADDM LNWORD!BPWORD!BPINC ]
PUSHJ P,STRGR ;AND FINISH OUT AND MARK IT.
POP P,B ;GET FIXUP ADDR
HRL B,PCNT ;FIXUP TO HERE
PUSHJ P,FBOSWP ;SWAP AND FBOUT
MOVE A,[REM!UNDO] ;NOW SUB IF NECESSARY AND REMOP
GETSEM (1) ;STRING SEMANTICS BACK AGAIN
JRST STROP
^LLEN1: SKIPA TBITS2,[HRRZ LNWORD] ;SPECIAL -- FOR INF -- DO NOT DAMAGE STRING.
^LLEN: MOVE TBITS2,[HRRZ LNWORD!UNDO] ;LENGTH OF STRING.
PUSHJ P,GETAN0 ;IN CASE REFERENCE ARG, NEED INDEXABLE.
STRGR: MOVE PNT,GENLEF+1 ;ARGUMENT.
GENMOV (ACCESS,GETD!INSIST,STRING)
TLNE TBITS,CNST ;IF A STRING CONSTANT NOW, JUST ANSWER
JRST CONLEN
MOVE A,TBITS2 ;ARGUMENT TO STROP.
STRDO: PUSHJ P,STROP ;DO IT ON THE STRING.
TRNE FF,UNDO ;NOT IF SPECIAL (STROP LEFT IT THERE)
^REMG0: PUSHJ P,REMOP
PUSHJ P,MARKINT ;MARK AN INTEGER.
G00: MOVEM PNT,GENRIG
POPJ P,
CONLEN: HRRZ A,$PNAME(PNT) ;THE ANSWER
PUSHJ P,CREINT ;A NUMERICAL CONSTANT
JRST G00 ;TRIVIALITY
BEND STRING
SUBTTL Point, Ldb, Ildb, Dpb, etc.
BEGIN BYTE
DSCR BYPS, BYPQ, BYPE
PRO BYPS BYPQ BYPE
DES EXECS for LDB, ILDB, IBP, DPB, etc.
They use the BYTAB, BYSAB tables in obvious ways to issue
the obvious code
TABCONDATA (BYTE POINTER EXEC VARIABLES)
COMMENT
BYTAB, BYSAB -- used by byte pointer EXECS to create the appropriate
byte pointer instructions.
BYTAB: ILDB 4
LDB
BYSAB: IDPB 4
DPB
IBPSAB: IBP NOUSAC!4
ENDDATA
^BYPQ: MOVEI B,IBPSAB-BYSAB ;IMPLEMENT 1-ARGUMENT
;; #KI# BY JRL (11-21-72) DO THE DUMMY GETAC FOR IBP
PUSHJ P,GETAC
JRST BYPQ1 ; VERSION OF IBP
^BYPS: MOVE PNT,GENLEF+3 ;THING TO BE DEPOSITED.
;;#JG# RHT 9-27-72 REGISTER B CLOBBERMENT
PUSH P,B
GENMOV (GET,GETD!POSIT!REM!ARITH);GET IT AND THEN REMOP IT.
POP P,B
;;#JG#
BYPQ1: TLO FF,FFTEMP ;A THING AT STATEMENT LEV.
MOVE A,BYSAB(B) ;GET INSTRUCTION.
JRST BY11
^BYPE: TLZ FF,FFTEMP
MOVE A,BYTAB-4(B) ;INSTRUCTION.
PUSHJ P,GETAC
BY11:
PUSH P,A ;SAVE
MOVE PNT,GENLEF+1 ;EXPRESSION.....
GENMOV (ACCESS,GETD!PROTECT!UNPROTECT) ;ARG.
POP P,A ;RESTORE
;;#IR# 7-22-72 DCS ILDB/IDPB(..., ARRAY[EXPR]) DIDN'T WORK, CLEAN OTHERS UP
TRNE A,4 ;For ILDB and IDPB operations,
;; #KE# ! BY JRL ALSO FIXARR OK
TLNE SBITS,INDXED!FIXARR ; temp (not counting INDXED) BPs
JRST BYOK ; make limited sense, so a message
TLNE SBITS,ARTEMP!STTEMP ; is issued. In the same instances,
ERR <BYTE POINTER MODIFICATION USELESS>,1
TLNN SBITS,ARTEMP!STTEMP ; we must avoid using the INAC versions
PUSHJ P,INCOR ; of BP variables, so this is tested.
;;#IR#
BYOK: PUSHJ P,EMITER
;;#UT# JFR 8-13-75 DPB AND IDPB CHANGE STORAGE; NEED AN ALLSTO
HLRZ TEMP,A ;OPCODE
CAIE TEMP,(<DPB>)
CAIN TEMP,(<IDPB>)
PUSHJ P,ALLSTO
;;#UT# ^
TLNN FF,FFTEMP
JRST REMG0 ;MARK AN INTEGER AND PUT IN GENRIG.
JRST REMOP ;GO AWAY.
Comment
Because byte pointers are so often comprised of constant
size and position fields, and of simple variables as addresses
(??), it seems appropriate to create these byte pointers at
compile time. Perhaps later a way can be determined to extend
this feature to more complicated things (at least FIXARR array calcs).
RTN: BBPP @E , SCAN ^EX1 RTP
RTP: BBPP @E , @E SCAN ^EX1 RTP1
RTP1: BBPP @E , @E , @E ) EXEC BPNT SCAN IE2
Only those cases for which the first two args are constants and the
last a simple real or integer variable will be considered.
^^BPNT:
MOVEI TBITS2,0
GETSEM (1) ;POSITION FIELD OF BYTE POINTER
TLNN TBITS,CNST ; MUST BE A CONSTANT
JRST CALLIT ; OR WILL CALL AT RUNTIME
GENMOV (CONV,INSIST,INTEGR) ;INTEGER POSITION FIELD ONLY
MOVEI TEMP,=35 ;CREATE REAL POSITION ENTRY
SUB TEMP,$VAL(PNT)
DPB TEMP,[POINT 6,TBITS2,5] ;AND MOVE TO APPROPRIATE LOC
GETSEM (5) ;SIZE FIELD
TLNN TBITS,CNST ; ALSO MUST BE CONSTANT
JRST CALLIT ; OR CALL AT RUNTIME
GENMOV (CONV,INSIST,INTEGR) ;MUST BE INTEGRAL
MOVE TEMP,$VAL(PNT) ;SIZE VALUE
DPB TEMP,[POINT 6,TBITS2,11] ;TO SIZE AREA
GETSEM (3) ;ADDRESS FIELD OF BYTE POINTER
TLNE TBITS,CNST ;CONSTANT ADDRESS FIELD?
ERR <CONSTANT QUESTIONABLE AS BYTE POINTER ADDRESS>,1
TDNN TBITS,[XWD FORMAL!SBSCRP,STRING] ;REALLY RESTRICTED CLASS
TLNE SBITS,ARTEMP!STTEMP!FIXARR ; OF THINGS WILL BE PROCESSED
JRST CALLIT ;SORRY, CHARLIE!
GENMOV (INCOR) ;SAFETY FOR POOR LOSER SOMETIMES
HLL PNT,TBITS2 ;BYTE POINTER STUFF FOR LH
PUSHJ P,ADRINS ;MAKE AN ADDRESS CONSTANT
MOVEM PNT,GENRIG ;THE RESULT!
POPJ P,
; SEE SLOP -- THIS IS THE MOST AMBITIOUS SIMULATION OF "PARSE" TO DATE
CALLIT: PUSH P,GENLEF+1 ;SAVE ALL SORTS OF SEMANTICS FOR
PUSH P,GENLEF+3 ; THE ARGUMENTS
PUSH P,GENLEF+5
MOVEI TEMP,.BBPP. ;WILL CALL THE POINT FUNCTION
MOVEM TEMP,GENLEF+1 ;READY FOR RDYCAL
PUSHJ P,RDYCL1 ;PREPARE TO CALL
MOVEW <GENLEF+2>,<GENRIG+1> ;SEMANTICS OF PROC BLOCK
REPEAT 3,<
POP P,GENLEF+1 ;AN ARGUMENT
PUSHJ P,CALARG ; TO THE STACK
>
JRST ISUCAL ;FINISH UP
^^BPTWD:
MOVE TEMP,GENLEF+1
MOVEM TEMP,GENRIG+1
POPJ P,
BEND BYTE
SUBTTL Swap Operator.
BEGIN SWAP
DSCR SWPR
PRO SWPR
DES The swap operator to interchange two variables.
@ISTO SWAP @ISTO drarrow S exec swpr
^SWPR:
SOJL B,SWPRK ;AN ARITHMETIC EXPR. OK.
JUMPE B,[ERR <BOOLEAN EXPR INVALID IN SWAP>,1 ;A BOOLEAN -- NO GOOD.
JRST SWPRK]
PUSHJ P,LEAVE ;IN LEAP...
SWPRK: GETSM2 (3)
GETSEM (1) ;NOW HAVE SEMANTICS OF BOTH ARGS.
TLNE SBITS,ARTEMP!STTEMP ;IF A TEMP EXPRESSION, LOSE.
TLNE SBITS,INDXED!FIXARR ;EXCEPT ON SUBSCRIPTS.
SKIPA
ERR <SWAP OPERATOR ON EXPRESSION>,1
TRNE TBITS,ITEM
ERR <ITEMS ARE CONSTANTS, CAN'T BE SWAPPED>,1
TRNE TBITS,ITMVAR
JRST NTSSTR
TRNN TBITS,STRING
TRNE TBITS2,STRING ;DO STRING THINGS IF EITHER IS
JRST SWPSTR ;A STRING.
TRNN TBITS,SET ;A SET OR LIST?
JRST NTSSTR ;NO.
MOVE TEMP,TBITS ;IF ONE GLOBAL OTHER SHOULD BE ALSO
XOR TEMP,TBITS2
GLOC <
TRNE TEMP,GLOBL
ERR <CAN'T SWAP GLOBAL TO LOCAL SET,LIST>,1
>;GLOC
TRNE TEMP,LSTBIT
ERR <CAN'T SWAP LIST TO SET>,1
NTSSTR: PUSH P,TBITS ;SAVE ORIGINAL TYPE
MOVE B,TBITS2
GENMOV (GET,INSIST!NONSTD!POSIT!EXCHOUT)
;GET FIRST ARG WITH TYPE OFSECOND.
;BUT PRESERVE SEMANTICS OF INDXED TEMP.
TLNN SBITS,INDXED
PUSHJ P,INCOR ;MAKE SURE EXCH DEST. IS IN CORE
GENMOV (ACCESS,PROTECT!UNPROTECT);MAKE SURE CAN GET AT SECOND ARG.
;; #OX# (1 OF 2) JRL SPECIAL TREATMENT FOR ? PARAMETERS
MOVE A,[EXCH 0] ;
TLNE TBITS,MPBIND ;A MATCHING PROCEDURE PARAMETER?
JRST [
HRR C,D ;SAVE AC NUMBER
GENMOV (GET,ADDR!INDX) ;GET ADDRESS OF ? ITEMVAR
MOVSS D ;WILL BE USED AS INDEX REGISTER
HRR D,C ;GET AC NUMBER BACK
MOVE A,[EXCH NOADDR!USX!NORLC]
TLZ TBITS,MPBIND ;SO TEMP WON'T BE MARKED AS MPBIND
JRST .+1]
PUSHJ P,EMITER ;EMIT THE EXCH
TRNN TBITS,ITMVAR
TRNE TBITS2,ITMVAR
JRST NTSS.1 ;ITEMVARS ARE NEVER DOUBLE
TRNE TBITS,DBLPRC
TRNN TBITS2,DBLPRC
JRST NTSS.1 ;NOT BOTH DOUBLE
ADDI D,1 ;SECOND AC
EMIT (<EXCH FXTWO>)
SUBI D,1
NTSS.1:
;; #OX#
;OF SECOND
PUSHJ P,REMOP ;DON'T NEED THIS ANY MORE
;;#HK#2! 5-17-72 DCS PREVENT TWO ARGS FIGHTING FOR SAME TEMP
PUSH P,ACKTAB(D) ;TEMPORARILY FORGET THAT THIS IS IN THIS
SETZM ACKTAB(D) ; AC, ALLOW A NEW TEMP TO BE BORN
;;#WP# JFR 4-12-76 SET UP RCLASS FOR RECORD!PONTERS
TRNE TBITS,PNTVAR
JRST [
HLRZ TEMP,$ACNO(PNT) ;CLASS INFO FROM POINTER
SKIPN RCLASS ;DONT'T MUNGE IF SOMEHOW OK
MOVEM TEMP,RCLASS ;SAVE THE WORLD FROM DRYROT AT MARK
JRST .+1]
;;#WP# ^
PUSHJ P,MARKME ; (IN FACT, WE NEED A TEMP
; WAS MARK -- THAT WAS WRONG
; OF THIS TYPE IN THIS AC
;;#HK#!
MOVE B,-1(P) ;GET ORIG TYPE BACK (WAS POP P,B)
GENMOV (CONV,INSIST!POSIT!SPAC);CHANGE IT TO TYPE OF FIRST.
PUSHJ P,REMOP ;REMOVE THE TEMP
;;#HK#2!
POP P,ACKTAB(D) ;REMEMBER OLD RESIDENT
SUB P,X11 ;REMOVE SAVED TYPES
TLZ SBITS2,INAC
MOVEM SBITS2,$SBITS(PNT2) ;SO THAT THE EMITER WILL SEE IT.
GENMOV (PUT,EXCHIN) ;STORE BACK INTO FIRST
JRST REMOP ;FERTIG.
Comment
The string problem is a little messy. If both are
strings, we just go ahead blithly. First we load
up accumulators with the addresses of the two
strings. Then we stack both strings. Then we put together
instructions popping them off the SP stack, using the
addresses saved in the accumulators just gotten.
SWPSTR: TRNE TBITS,STRING ;HERE IF EITHER IS A STRING.
TRNN TBITS2,STRING
ERR <TYPE CONVERSIONS TOO MESSY>,1,CPOPJ
GENMOV (GET,ADDR!INDX) ;GET THE ADDRESS OF THE FIRST.
PUSH P,D
GENMOV (GET,EXCHIN!ADDR!INDX)
PUSH P,D
GENMOV (STACK,0) ;STACK THE FIRST STRING.
GENMOV (STACK,EXCHIN!EXCHOUT) ;AND THE SECOND (SEE THE GENMV2).
HRL D,(P) ;FOR THE INDEX FIELD
PUSHJ P,DOIT
EXCHOP
HRL D,-1(P)
SUB P,X22
DOIT: SETZM C ;EMIT TWO POPS TO STORE THE STRING.
EMIT (<POP RSP,NOUSAC!USX!NOADDR>)
SETOM C
EMIT (<POP RSP,NOUSAC!USX!USADDR!NORLC>)
MOVSS D
PUSHJ P,CLEARA ;CLEAR AC # USED FOR SWAP
SUBTR: MOVNI A,2
ADDM A,SDEPTH ;WE HAVE TO BOOKEEP THIS COUNT.
POPJ P, ;DONE
BEND
SUBTTL Store Operator
BEGIN STORE
DSCR STORE
PRO STOR1
DES EXECS for the assigment operator.
The store operators are handled mostly in the lower level
generator code. The only distinction made here is whether
to do the remop. STOR1 is called at expression level,
and therefore does no remop; STORE does the remop.
The syntactic context is:
LHS E SG drarrow xxx STORx
The problems with STORE result from the expr store configuration:
vbl _ (array descriptor) _ vbl;
or worse:
String vbl _ string array descriptor _ String vbl
In this last case, we are careful to push the string on the
SP stack, so that an add to the SP will deliver the String.
^STOR1: TLOA FF,FFTEMP ;INDICATE NO REMOP
^STORE: TLZ FF,FFTEMP ;INDICATE A REMOP
SOJL B,.+3 ;REGULAR EXPRESSION
JUMPN B,LPSTOR ;..LEAP..
PUSHJ P,LEVBOL ;BOOLEAN.
;;#IA# 6-29-72 (1-6) DCS BETTER AC PROTECTION
^STORG: HRRZS PNT,GENLEF+2 ;Protect the AC if the destination is
PUSHJ P,GETAD ; a PTRAC temp (subscripted variable,
TLNN SBITS,PTRAC ; subscrp calc. in AC. -- This will prevent
JRST NOPTR ; the GET operation from storing the
HRRZ D,$ACNO(PNT) ; pointer, only to have to pick it up
HRROS ACKTAB(D) ; again to do the STORE.
HRROS GENLEF+2 ;Indicate that this was done
;;#IA#(1-6)
NOPTR:
REC < ;SINCE WILL INSIST
HLRZ B,$ACNO(PNT) ;GET THE TYPE
TRNE TBITS,PNTVAR ;MAKE SURE INSIS DOESN'T COMPLAIN
HRRZM B,RCLASS
>;REC
HRRZ B,TBITS ;DESTINATION TYPE.
MOVE PNT,GENLEF+1 ;SOURCE
MOVEI D,RSP ;USE THIS STACK.IN CASE STRINGS.
HRRI FF,INSIST!EXCHOUT!GETD;WE WANT TO "GET" THE SOURCE.
;;#IJ# JRL 7-5-72 A STRING ITEMVAR IS NOT A STRING
TRNE B,ITEM!ITMVAR
JRST NOPTR1
;;#IJ#
TLNE FF,FFTEMP ;IF STANDARD STORE
TRNN B,STRING ;OR DESTINATION NOT A STRING
JRST [NOPTR1:GENMOV (GET)
CAIE D,RSP
JRST GENGO
JRST GENG1]
GENMOV (STACK)
GENG1: TRZA FF,-1
GENGO: HRRI FF,PROTECT!UNPROTECT
MOVE PNT,GENLEF+2 ;AND GET DESTINATION SEMANTICS.
TRO FF,GETD ;ADD TO (PERHAPS) PROTECTION
PUSHJ P,ACCESS ;ASSURE ACCESS TO IT (PERHAPS PROTECT AC)
;;#IA# 6-30-72 DCS (2-6) UNPROTECT DEST IF NECESSARY
JUMPGE PNT,NOUNP ;IF WAS PROTECTED, UNDO
HRRZ TEMP,$ACNO(PNT)
HRRZS ACKTAB(TEMP)
;;#IA# (2-6)
NOUNP:
;; #QS# ! (CMU =A3=) COPY THE BIT DON'T TAKE OR OF SBITS,SBITS2
TLZ SBITS,NEGAT ;
TLNE SBITS2,NEGAT ;COPY THIS BIT INTO THE THING TO MARK
TLO SBITS,NEGAT ;FOR STORING.
HRRI FF,0
TLNE FF,FFTEMP ;IF AN EXPR. STORE, THEN
TRO FF,NONSTD ; BE SURE TO SAVE INDXED TEMPS.
GENMOV (PUT) ;MARK THE STORE.
;;#WQ# JFR 4-12-76 REMOP THE PTR AC FOR "STR_CLASS:STRFIELD[PTR];"
MOVE TEMP,$VAL2(PNT2)
CAIN TEMP,-1 ;SPECIAL?
JRST .+3 ;DO THE REMOP2 WITHOUT FURTHER ADO
TRNN TBITS,ITEM!ITMVAR ;
TRNN TBITS,STRING ; STACK HAS ALREADY REMOPPED IF STRING
PUSHJ P,REMOP2 ;REMOP THE EXPRESSION PART OF THINGS.
;;#WQ# ^
TLNN FF,FFTEMP ;EXPRESSION STORE ?
JRST REMOP ;REMOVE THE DESTINATION IF TEMP.
;PNT NOW HAS DESTINATION IN IT.
TLNE SBITS,STTEMP
TRNN TBITS,STRING ;IF WE ARE NOT TO MARK STRING, THEN
JRST [TRNE TBITS,ITMVAR!SET
;#HL#. FOLLOWING WAS HRRZM WHICH WIPED OUT INFO IN LEFT HALF.
HRRM PNT,@LEAPSK ;RESTORE THE TOP OF LEAP STACK.
JRST PUT1] ;JUST RETURN SEMANTICS.
;;%DN% JFR 7-4-76
HRLI C,2
PUSHJ P,ESPADJ ;BUMP SP BY 2
;; MOVE PNT2,PNT ;SAVE FOR LATER.
;; MOVE A,X22 ;FIRST ADD TO THE STACK.
;; PUSHJ P,CREINT
;; EMIT (<ADD RSP,NOUSAC>)
MOVEI A,2
ADDM A,SDEPTH ;AND FIXUP THIS WONDERFUL COUNT.
;; MOVE PNT,PNT2
;; MOVE TBITS,$TBITS(PNT);RESTORE BITS.
;;%DN% ^
^MARK1: GENMOV (MARK,0) ;YES -- GO MAKE A TEMP.
;WE MUST DO THIS IN CASE OF INDEXED VBLS.
^PUT1: MOVEM PNT,GENRIG+1 ;SAVE AS SEMANTICS.
^CPOPJ: POPJ P, ;STORE AS THE SORUCE FOR THE NEXT.
BEND STORE
SUBTTL Booleans -- Description
BEGIN BOOLEAN
DSCR --Boolean Expression code
DES very hairy.
SEE incredibly complex RFS comments below this DSCR
COMMENT
This section contains the routines for generating the code
for boolean expressions.
It consists of 3 parts:
1. A routine called to promote an arithmetic expression
to a boolean primary, or to promote a simlpe boolean
variable to a boolean primary.
2. A routine to generate compare code for relational expressions.
3. Routines called from the boolean expression productions, e.g.
BOOR, BOAND, and BONOT.
The routines above all generate information in free storage blocks.
These are classed in two categories, terminal nodes (one to
represent each boolean primary) and non-terminal nodes (one for each
logical operation, such as NOT, OR, AND). The recursive routine
GBOL wanders through this structure, outputting necessary code and
address fixups to the binary file. It deletes all the storage
entries as it goes. The format of each entry looks like:
1. TERMINALS.
$DATA xwd conbits,pointer to right brother.
$DATA2 b.p. for reloc bits
$DATA3 b.p. for instrs emited
$DATA4 reloc bits
$DATA4+1 pcnt,, #instrs
$DATA4+2 instructions as emitted (possibly thru $DATA4 +4)
Conbits are declared in bit list below
2. NON-TERMINALS.
$DATA xwd gtype+400000,pointer to right brother
$DATA2 pointer to left son.
Gtype bits are declared below.
The syntactic contexts are:
NOT BP SG drarrow BP SG BONOT
BT AND BP SG drarrow BT SG BOAND
BE OR BT SG drarrow BE SG BOOR
BITDATA (BOOLEAN TREE ELEMENTS)
; Nonterminals
GBAND __4 ;TYPE BIT FOR "AND"
GBOR __10 ;FOR "OR"
GBPOS__15 ; POSITION OF GBAND IN LH OF TYPE WD
GBNOT __20 ;AND "NOT"
GINVRT __40 ;INVERT SENSE BIT.
MOSTTRUE__100 ;MOST SONS ARE TRUE.
LASTTRUE__200 ;LAST SON IS TRUE.
METRUE__400 ;I AM TRUE TO YOU, MY DEAR.
FLSFIX__1000 ;SOMEONE STARTED A FALSE FIXUP.
TRUFIX__2000 ;OR A TRUE FOR THAT MATTER.
; Terminals
TRUCON__2 ;TRUE CONSTANT
FLSCON__1 ;FALSE CONSTANT
BOLCON__TRUCON!FLSCON ;EITHER
ENDDATA
SUBTTL Variables
ZERODATA (BOOLEAN EXPRESSION VARIABLES)
;FAPDL -- special push-down list for storing addresses of code
; which jump to false addresses -- used to get fixups right
BPDL__10
?FAPDL: BLOCK BPDL
;TRPDL -- corresponding stack for true addresses
?TRPDL: BLOCK BPDL
?LPSAV: 0 ;PLACE TO PUT LPSA SOMETIMES
TABCONDATA (BOOLEAN EXPRESSION VARIABLES)
COMMENT
CONVS, CONVT -- conversion routines
CONVS converts the bits of a compare or jump instruction
to those needed to reverse the meaning of a compare (jump
on False condition instead of True, for instance).
CONVT converts the bits to those needed to reverse the operands
of a compare (2d operand already in AC, for instance).
;;CONVT: 0
;; 7
;; 2
;; 5
;; 4
;; 3
;; 6
;; 1
;;#UB# RHT 2-21-75 ADD A LHS TO THE BELOW TABLE. THE LHS VALUES
;; WILL REVERSE THE SENSE OF ALL JUMPS EXCEPT JUMPN & JUMPE
;;CONVS: XWD 4,4
;; XWD 5,5
;; XWD 2,6
;; XWD 7,7
;; XWD 0,0
;; XWD 1,1
;; XWD 6,2
;; XWD 3,3
;;#UB# ^
;RELTAB -- conditional bits (to go into instructions) corresponding
; to the class index of the condition (=, <, >, etc.) from the source
; file -- used to convert class index to instruction bits
^RELTAB: 1 ;<
7 ;>
2 ;=
6 ;
3 ;LEQ
5 ;GEQ
; 0 ;TRUE
; 4 ;FALSE
;BORELD, BORELE -- 2nd and 3rd instructions for doing double operations
; on constants at compile time
BORELD: ERR <DRYROT BOREL LONG>,1
CAMGE C,$VAL2(PNT)
CAME C,$VAL2(PNT)
CAMG C,$VAL2(PNT)
ERR <DRYROT BOREL LONG>,1
CAML C,$VAL2(PNT)
CAME C,$VAL2(PNT)
CAMLE C,$VAL2(PNT)
BORELE: ERR <DRYROT BOREL LONG>,1
CAMLE B,$VAL(PNT)
CAI
CAMLE B,$VAL(PNT)
ERR <DRYROT BOREL LONG>,1
CAMGE B,$VAL(PNT)
CAIA
CAMGE B,$VAL(PNT)
;CONDD -- bits to use in 2nd and 3rd instr of double CAM, SKIP for
; double compare operations, corresponding to original cond bits
CONDD: 0
5,,3 ;LSS INTO GEQ,,LEQ
2,,0 ;EQ INTO EQ,, noop
7,,3 ;LEQ INTO GTR,,LEQ
0
1,,5 ;GEQ INTO LSS,,GEQ
2,,4 ;NEQ INTO EQ,, always
3,,5 ;GTR INTO LEQ,,GEQ
ENDDATA
SUBTTL Arith TO Relop
DSCR BOOP, BOREL
PRO BOOP BOREL BOREL1
DES EXECS to generate compare/jump code for simple relations
and implied relations ("IF A<B" or "IF A")
SEE Above-mentioned comments for more help
^^BOPBLK: ;GET A FREE STORAGE BLOCK FOR BOOLEAN PURPOSES.
GETBLK <GENRIG+1>
MOVSI TEMP,(1B1)
MOVEM TEMP,$DATA4(LPSA) ;PC IS RELOC
MOVEI TEMP,$DATA4(LPSA) ;ADDR FOR RELOC BITS
HRLI TEMP,420200 ;RELOC BITS 2/WORD, ONLY USE RIGHT BIT
MOVEM TEMP,$DATA2(LPSA)
MOVEI TEMP,$DATA4+2(LPSA) ;ADDR FOR INSTRS EMITED
HRLI TEMP,444400 ;INSTRS ARE FULL WORDS
MOVEM TEMP,$DATA3(LPSA)
POPJ P,
;COME HERE TO CONVERT A BOOLEAN VARIABLE OR ARITHMETIC EXPRESSION
;INTO A BOOLEAN PRIMARY. A "PRIMARY" BLOCK IS CREATED.
^BOOP: TLO FF,FFTEMP ;WILL REMOP THE FIRST ARGUMENT
PUSHJ P,BOPBLK
MOVE PNT,GENLEF+1 ;THIS IS THE ONE WE WANT TO PROTECT FROM
GENMOV (CONV,GETD!ARITH) ;IN CASE THE BASTARD INSISTS ON STRINGS.
;;# # DCS 2-28 CONSTANT EXPRS
TLNE TBITS,CNST ;IF CONSTANT, DETERMINE TRUE/FALSE
JRST [MOVSI TEMP,FLSCON ;ASSUME FALSE
TRNE TBITS,DBLPRC
SKIPN $VAL2(PNT) ;TEST LOW WORD OF DOUBLE CONST
SKIPE $VAL(PNT) ;HIGH ORDER OR ONLY WORD
TR: MOVSI TEMP,TRUCON ;ASSUMPTION INVALID
FL: MOVE LPSA,GENRIG+1;UPDATE RESULT
MOVEM TEMP,$DATA(LPSA)
JRST REMOP] ;TOSS OUT NUMERIC (OR 2D, SEE RELOP) ARG.
MOVE PNT2,PNT ;PROTECT THIS ONE FROM THE BOLSTO !!!
PUSHJ P,BOLSTO ;SPECIAL BOOLEAN STORES.....
MOVEI C,6 ;THE RIGHT CODES , AND.....
JRST VAL0 ;GO OUTPUT A SKIPxx OR JUMPxx
^BOREL1: TLZ FF,FFTEMP ;TELL NOT TO REMOP THE EXPRESSION.
PUSHJ P,BORELL ;THIS IS FOR RELATIONS SUCH AS 1<C<D<34
MOVE A,GENRIG+1 ;SEMANTICS GENERATED FOR BOOLEAN
MOVEM A,GENRIG+3
MOVE A,GENLEF+1 ;SEMANTICS OF REMAINING EXPRESSION.
MOVEM A,GENRIG+1
MOVE A,PARLEF ;RELATION TYPE.
MOVEM A,PARRIG
POPJ P,
SUBTTL Relational Operators
;COME HERE TO GENERATE THE COMPARE INSTRUCTION FOR A RELATIONAL OPERATOR.
;THE PARSER PASSES IN REGISTER "B" AN INDEX APPROPRIATE TO THE
;OPERATOR IT SAW.
^BOREL: TLO FF,FFTEMP ;TELL TO REMOP EXPRESSION 1.
BORELL:
SKIPE THISE ;IF ARITHMETIC EXPRESSION
JRST STREL ;THEN DON'T GO TO LEAP
^^IREL: ;COME BACK HERE IT ITEM RELATIONS
PUSHJ P,BOPBLK ;GET FREE STORAGE BLOCK TO DIDDLE WITH
PUSH P,RELTAB(B) ;CONDITION BITS FOR THIS OPERATOR.
;;#GO# DCS 2-6-72 (4-4)
PUSHJ P,GTARGS ;SEMS OF BOTH ARGS TO PNT, ETC., 2D TO AC IF NECC
;;#GO# (4)
TRNN TBITS,ITEM!ITMVAR
TRNE TBITS2,ITEM!ITMVAR
;; #PT# MAKE SURE THAT IF WE HAVE ITEM HERE WE WENT TO LEAP TO PROCESS IT
JRST [SKIPN THISE ;NON-ZERO IF WE WENT TO LEAP FOR TYPE CHECKING
ERR <ITEM TYPE MISMATCH>,1
JRST RSEMOK]
;; #PT#
HRRI FF,ARITH!BITS2!EXCHOUT!POSIT
;;GOING TO INSIST ON ARITHMETIC ARGS.
MOVEI B,(TBITS)
IORI B,(TBITS2)
ANDI B,FLOTNG!DBLPRC
TRNN TBITS2,FLOTNG!DBLPRC
TRNE TBITS,FLOTNG!DBLPRC
TRC FF,INSIST!ARITH ;INSIST IF EITHER FLOTNG OR DBL APPEARS
GENMOV (CONV) ;FIRST ARGUMENT.
TRZ FF,EXCHIN!EXCHOUT ;DO IT FOR SECOND ARG.
GENMOV (CONV) ;AND SECOND ARGUMENT.
RSEMOK: TLNE TBITS2,CNST ;CHECK FOR BOTH CONSTANT
JRST [TLNN TBITS,CNST ;WELL?
JRST NTBCN
TRNN TBITS,ITEM!ITMVAR
TRNE TBITS2,ITEM!ITMVAR
JRST RSEMK1
TRNN TBITS,DBLPRC
TRNE TBITS2,DBLPRC
JRST [DMOVE B,$VAL(PNT2) ;DO OP ON DBL CONSTS
POP P,TEMP ;CONDITION BITS
CAMN B,$VAL(PNT) ;FIRST INSTR
XCT BORELD(TEMP) ;2ND
XCT BORELE(TEMP) ;3RD
JRST [PUSHJ P,REMOP2
MOVSI TEMP,FLSCON
JRST FL]
PUSHJ P,REMOP2
JRST TR]
RSEMK1: MOVE A,[CAM B,C] ;PREPARE TO INTERPRET
POP P,C ;CONDITION BITS
DPB C,[POINT 3,A,8]
MOVE B,$VAL(PNT2);ARGS ARE REVERSED AT THIS POINT
MOVE C,$VAL(PNT)
PUSHJ P,REMOP2 ;DITCH SECOND CONST
MOVSI TEMP,FLSCON;ASSUME FALSE
XCT A ;COMPARE
JRST FL ;NOT TRUE
JRST TR] ;TRUE
NTBCN: TLNN FF,FFTEMP
JRST [GENMOV (GET)
JRST TYPOK]
TYPOK: POP P,C ;*** SHOULD PROTECT BETTER -- PROBLY IN TOTAL
;CONDITION BITS.
PUSHJ P,BOLSTO ;SPECIAL BOOLEAN STORE.
TLNE FF,FFTEMP ;ALWAYS MAKE SURE SECOND ARG. IS LOADED.
TLNE TBITS2,CNST ;IF THIS IS CONSTANT, THEN
JRST BREV ;WE SHOULD CHANGE ORDER.
TLNE SBITS,INAC ;IF THIS IS IN AC, THEN GOOD ORDER.
TLNE TBITS,CNST ;IF THIS IS CONSTANT, NO NEED TO
JRST BGOOD ;TEST INAC BITS.
TLNE SBITS2,INAC
JRST BGOOD
BREV: TRNE C,1 ;REVERSE ORDER OF COMPARE. IF <> THEN
XORI C,6 ;CHANGE INSTR
JRST BGET
BGOOD: TLC C,1 ;INDICATE THAT ONE EXCHOP IS DONE.
EXCHOP
BGET: TLNE TBITS2,CNST ;IS THE SECOND ARG. A CONSTANT?
JRST [TRNE TBITS2,ITEM!ITMVAR
JRST BGOT
TRNE TBITS2,DBLPRC ;YES, CHECK PRECISION
SKIPN $VAL2(PNT2) ;2ND WORD OF DOUBLE CONST
SKIPE $VAL(PNT2) ;FIRST OR ONLY WORD
JRST BGOT ;NOT ZERO, NO HOPE FOR SEXY THINGS
JRST VAL0]
JRST BGOT ;NO HOPE FOR SEXY THINGS.
VAL0: TLNN SBITS,INDXED!PTRAC!FIXARR ;HERE TO GENERATE A SKIPE,
; SKIPN, JUMPN OR JUMPE.
TLNN SBITS,INAC ;IN AN ACCUMULATOR?
JRST BSKP ;A SKIP REQUIRED -- NOT IN AC.
BJMP: HRR D,$ACNO(PNT) ;GET AC NUMBER.
;;#UB# SUPERSEDED BY INTELLIGENT CODE. #UB EVEN HAD IT WRONG: #UB CHANGED
;; -X GEQ 0 INTO X LSS 0 INSTEAD OF X LEQ 0
TLNE SBITS,NEGAT
TRNN C,1
TRCA C,4 ;X {<,>,=,, , ~ 0 into JUMP{GE,LE,N,E,G,L~ X,[false]
; also -X{=,~0 into JUMP{N, E~ X,[false]
XORI C,2 ;-X {<,>, , ~ 0 into JUMP{LE,GE,L,G~ X,[false]
;;#UB# -- INVERT SENSE IF NEGAT UNLESS WAS A ZERO TEST
;; HRR C,CONVS(C) ;ASSUME INVERT
;; TLNE SBITS,NEGAT ;UNLESS NEGAT
;; HLR C,CONVS(C) ;INVERT THE TEST CONDITIONS BACK (EXCEPT 6 AND 2)
;;#UB# ^
MOVE A,[JUMP USCOND+NOADDR] ;1 INSTR WORKS, EXCEPT FOR LONG INTEGERS
PRINTX ASSUMING NO LONG INTEGERS
JRST BODON3 ;EMIT THE JUMPxx, FINISH OUT AND MARK THE STORAGE BLOCK.
BSKP: GENMOV (ACCESS,0) ;GUARANTEE ACCESS TO OUR FRIENDLY ARGUMENT.
;DO NOT WORRY ABOUT NEGAT -- THIS THING
;IS IN CORE -- GUARANTEED POSITIVE.
MOVE A,[SKIP NOUSAC!USCOND]
JRST BFIN ;1 <SKIP> ENOUGH FOR EVERYBODY EXCEPT LONG INTEGERS
BGOT: GENMOV (GET,POSIT!BITS2!EXCHOUT);MAKE SURE ACCUMULAOR IS FULL.
TLC C,1 ;INDICATE ANOTHER EXCHOP DONE.
;;%DU% ! JFR 1-4-77
GENMOV (ACCESS,ACESS2) ;MAKE SURE WE ARE SAFE.
MOVE A,[CAM USCOND] ;THE COMPARE OPERATION!
TRNN TBITS,ITEM!ITMVAR
TRNN TBITS,DBLPRC
JRST .+2
JRST [
PUSH P,C ;SAVE CONDITION BITS
HRRI C,6 ;FIRST INSTR IS skipN OR camN
PUSHJ P,EMITER
;1ST INSTR ALWAYS SAME, NOT RECORDED
ADDI D,1 ;2ND INSTR USES 2ND AC (IF ANY)
IORI A,FXTWO ;2ND WORD OF DBL
HRR C,(P) ;ORIGINAL COND BITS
HLR C,CONDD(C) ;BITS FOR THIS INSTR
PUSHJ P,EMITER
SUBI D,1 ;3RD INSTR USES ORIG AC (IF ANY)
TRNN C,1 ;EQ or NEQ?
JRST [PUSH P,D ;YES. THIS IS HARD
PUSHJ P,GETAC
HRLI C,(D)
EMIT (<TDZA NORLC!USADDR>)
EMIT (<SETO NOADDR>)
MOVE A,[JUMPL NOADDR]
MOVE C,-1(P) ;ORIG COND BITS
TRNN C,4
TLC A,(<JUMPL><JUMPGE>) ;EQ. AC=0 MEANS FALSE
PUSHJ P,EMITER
POP P,D
POP P,C
JRST BODON4]
PUSHJ P,BODON ;RECORD 2ND INSTR
TRZ A,FXTWO ;FIRST WORD, PLEASE
POP P,C ;REMOVE COND BITS
HRR C,CONDD(C) ;BITS FOR THIS INSTR
JRST .+1]
BFIN: PUSHJ P,EMITER
PUSHJ P,BODON
MOVE A,[JRST NOADDR+NOUSAC] ;THE FOLLOWING JRST.
BODON3: PUSHJ P,EMITER
BODON4: TLNN C,1 ;TEST NUMBER OF EXCHOPS
EXCH PNT,PNT2 ;WE ARE REMOPPING GENLEF+3
PUSHJ P,REMOP ;THESE MUST BE REMOPED, IN CASE THEY WERE EXPRS.
PUSHJ P,CLEAR ;THEY MUST ALSO BE TOTALLY FORGOTTEN.
;******* THESE REMOPS REALLY WANT TO BE DONE ON THE OPERANDS,
;******* NOT FROM THE SEMANTIC CELLS. THIS IS BECAUSE IN THE
;******* SPECIAL CASE, WE DO NOT WANT TO DO THE REMOP, E.G. 1<E<F<45 .
BODON1: EXCH PNT,PNT2 ;PREPARE TO REMOP THE OTHER ARG.
PUSHJ P,REMOP
PUSHJ P,CLEAR ;LIKE SO.
TLNE FF,FFTEMP ;SHOULD WE MAKE A TEMP ?
JRST BODON ;NO ----- GO ON.
MOVEM A,TBITS2
SETZM SBITS ;PREPARE TO MARK.
GENMOV (MARK,0)
MOVEM PNT,GENLEF+1 ;SEE BOREL1 FOR DETAILS OF THIS.
MOVE A,TBITS2
^BODON: MOVE LPSA,GENRIG+1 ;POINTER TO RESULT BLOCK SET UP BY BOLBLK.
SKIPN $DATA4+1(LPSA) ;ANY PCNT THERE?
JRST [MOVE TEMP,PCNT ;NO. PUT IT IN
SUBI TEMP,1 ;PCNT OF LAST INSTR
HRLZM TEMP,$DATA4+1(LPSA)
JRST .+1]
MOVE TEMP,LSTRLC ;RELOCATION BIT OF LAST WORD EMITTED.
IDPB TEMP,$DATA2(LPSA) ;SAVE RELOC BIT
MOVE TEMP,LSTWRD ;LAST WORD OF CODE EMITED
IDPB TEMP,$DATA3(LPSA) ;SAVE IT, TOO
AOS $DATA4+1(LPSA) ;ANOTHER WORD IN THIS BLOCK
POPJ P,
SUBTTL Connectives, Negation
DSCR BONOT, BOAND, BOOR
PRO BONOT BOAND BOOR
DES EXECS to combine simple relationals into more complex
relationals ("rel AND rel" etc.). These EXECS do not
generate code. They simply create a tree structure for
the GBOL De-Morganizer below
SEE Above-mentioned comments for help
;COME HERE WHEN YOU SEE A "NOT"
^BONOT:
MOVE PNT,GENLEF+1 ;ARGUMENT
MOVE A,$DATA(PNT) ;SPEC BITS
TLNE A,BOLCON ;TRUE OR FALSE CONSTANT?
TLCA A,BOLCON ;YES, INVERT
TLC A,GBNOT ;NO, MARK FOR LATER INVERSION
;;# # DCS TLC STATT TLO ALLOWS
MOVEM A,$DATA(PNT) ;UPDATE IN MEMORY
POPJ P, ;RETURN.
;COME HERE WHEN YOU SEE AN "OR" OR "AND".
^BOAND: MOVE A,GENLEF+3
MOVEM A,GENRIG+1 ;THE RESULTS IS A PRIMARY ++ BUT.
;THE KLUDGE IS SO THAT A<B<C WORKS.
SKIPA A,[400000+GBAND]
^BOOR: MOVEI A,400000+GBOR
MOVE LPSA,GENLEF+3 ;FIRST ARGUMENT (TERM OR EXPRESSION)
MOVE USER,GENLEF+1 ;NEW ARGUMENT.
HLRZ D,$DATA(LPSA) ;TYPE OF EXPRESSION
HLRZ C,$DATA(USER) ; " OF 2D
TRNE D,BOLCON ;1ST A CONSTANT?
JRST CONB1 ; YES, GO TEST FOR BOTH
TRNE C,BOLCON ;2D A CONSTANT?
JRST CONB2 ; YES, GENERATE SIMPLIFIED CODE
CONBAK: CAME D,A ;IS THE EXPR (OR TERM) OF THE SAME BOOLEAN
JRST BNOSAM ;TYPE? -- NO
SKIPA LPSA,$DATA2(LPSA) ;LEFT SON
BOOT: RIGHT ,$DATA,BOOS ;GO DOWN LOOKING FOR END OF LIST.
MOVEM LPSA,LPSAV
JRST BOOT
BOOS: HRRZ LPSA,LPSAV ;LAST BROTHER.
HRRM USER,$DATA(LPSA) ;LINK IN
POPJ P, ;RETURN
;SEMANTICS WILL ATUOMATICALLY BE CORRECT.
BNOSAM: TRNN A,GBAND ;AN "AND"?
JRST GETWW ;NO -- HAVE NO HOPES.
; MOVE USER,GENLEF+1 ;***** KLUDGE FOR A<B<C<D>E TO WORK *****
HLRZ D,$DATA(USER) ;THE TYPE,,RIGHT BROTHER POINTER.
CAME D,A
JRST GETWW
; MOVE USER,GENLEF+1 ;THIS IS NOW THE GUY WITH THE EXPR. TYXES.
MOVE C,$DATA2(USER) ;LEFT SON
; MOVE LPSA,GENLEF+3
HRRM C,$DATA(LPSA) ;NOW THE BROTHERS ARE LINKED.
MOVEM LPSA,$DATA2(USER) ;NEW LEFT SON POINTER.
MOVEM USER,GENRIG+1
POPJ P,
GETWW: GETBLK <GENRIG+1> ;NEED NEW BLOCK.
MOVSM A,$DATA(LPSA) ;TYPE BITS.
MOVE USER,GENLEF+3 ;FIRST ARGUMENT.
HRRZM USER,$DATA2(LPSA) ;LEFT SON
MOVE LPSA,GENLEF+1 ;SECOND ARGUMENT.
HRRM LPSA,$DATA(USER) ;RIGHT BROTHER.
POPJ P, ;RETURN
SUBTTL Constant Connectives
; FIRST ARG CONSTANT, CHECK SECOND
CONB1: TRNN C,BOLCON ;WELL?
JRST EXCH2 ; NO, REVERSE ARGS, GENERATE SIMPLE CODE
MOVEM LPSA,GENRIG+1 ;FIRST ARG IS RESULT
FREBLK (USER) ;ALL DONE WITH SECOND
ADD D,C ;2=BOTH FALSE, 3=ONE EACH, 4=BOTH TRUE
MOVSI TEMP,TRUCON ;ASSUME TRUE
XCT [JFCL ;BOTH FALSE, FALSE
TRNN A,GBOR ;ONE TRUE, TRUE IF `OR', ELSE FALSE
CAIA]-2(D) ;BOTH TRUE, TRUE
MOVSI TEMP,FLSCON ;IF YOU GET HERE, IT WAS FALSE
MOVEM TEMP,$DATA(LPSA);UPDATE IN BLOCK
POPJ P,
EXCH2: EXCH LPSA,USER
EXCH D,C ;2D ARG IS THE CONSTANT
;#IM# 2! 7-9-72 RHT SWAP 1 & 2 ARGS IN TREE, TOO
MOVEM LPSA,GENLEF+3 ;PUT THEM BACK FOR GETWW
MOVEM USER,GENLEF+1
CONB2: TRNN C,TRUCON ;IS 2D ARG TRUE?
JRST FT ;NO
TRNN A,GBOR ;BE `OR' TRUE eqv TRUE?
JRST RETEXP ;NO, BE `AND' TRUE eqv BE
MOVSI B,(<JUMP>) ;YES, NO-OP TO TRUE PART
JRST ONEOUT
FT: TRNN A,GBAND ;BE `AND' FALSE equiv to FALSE?
JRST RETEXP ;NO, BE `OR' FALSE equiv to BE
MOVSI B,(<JUMPA>) ;YES, JUMP-ALWAYS TO FALSE PART
ONEOUT: MOVEM B,$DATA4+2(USER) ;RECORD THE INSTR
IORI B,NOUSAC!NOADDR ;INSERT THESE BITS FOR EMITER
SETZM $DATA4+3(USER) ;INSURE NO SECOND INSTR
HRL TEMP,PCNT
HRRI TEMP,1 ;PCNT OR JUMP,,JUMP ONLY
MOVEM TEMP,$DATA4+1(USER)
SETZM $DATA(USER) ;NO BROTHERS, NO TYPE BITS
MOVSI TEMP,(1B1)
MOVEM TEMP,$DATA4(USER) ;PC IS RELOC, REST ARENT
MOVEI TEMP,$DATA4(USER) ;MAKE BYTE POINTERS LOOK RIGHT
HRLI TEMP,400200
MOVEM TEMP,$DATA2(USER) ;B.P. FOR RELOC BITS
MOVEI TEMP,$DATA4+2(USER)
HRLI TEMP,004400
MOVEM TEMP,$DATA3(USER) ;B.P. FOR INSTR EMITED
EXCH A,B ;GET INSTRUCTION
PUSHJ P,EMITER
MOVE A,B ;GET TYPE OF CONNECTIVE BACK
JRST GETWW ;GO RECORD RESULT
RETEXP: FREBLK (USER) ;USELESS BOOLEAN CONSTANT
MOVEM LPSA,GENRIG+1 ;FIRST ARG IS RESULT
POPJ P,
SUBTTL Gbol -- Discussion
DSCR GBOL
CAL PUSHJ from IF-type EXECS below
DES Examines the tree set up by above EXECS, re-issues
conditional code to reflect proper checks. Extremely
convoluted. See comments above and just below for help
Comment
When the boolean expression evaluator GBOL is called, all the code
for testing the boolean conditions has already gone out. We have
remembered in various free storage blocks the actual code emitted,
and can thus go back and link up the jumps and if necessary change
the sense of the compares or jumps in the test instructions.
The logical nature of the structure has been developed by the calls
on BONOT, BOAND, BOOR above. These routines have built a tree
structure representing the boolean expression. The non-terminal
nodes represent connectives. The handling of NOT is done at all
levels -- a terminal or non-terminal may be marked with GBNOT to
indicate that a NOT preceded this term in the expression.
The basic idea of the GBOL routine is as follows: When we see the
connective "AND", we want to arrange for all of the "sons" of
the connective to have tests which fall through when the test
evaluates to TRUE, and jumps out when it evaluates to FALSE.
This desire is indicated by turning on MOSTTRUE and LASTTRUE.
When the major connective is an "OR", we want all but the last
term to fall through on FALSE, and jump on true. The last term
should fall through on TRUE and jump on FALSE. These conditions
are indicated by turning off MOSTTRUE and on LASTTRUE.
But this is a simple description. Suppose the non-terminal
is part of a node which has been directed to fall through on
FALSE. Then METRUE is off in the state word. This information
is passed on to the rightmost son. The other sons do whatever
the connective specifies.
The NOTS are handled as we descend the tree, changing AND to OR, etc.
The bits FLSFIX and TRUFIX are merely used to remember at what
levels we had to start new fixup chains. When coming back up,
we have to resolve these fixups.
GBOL is called with the pointer to the tree structure in LPSA.
The push-down pointers for FALSE and TRUE are assumed set up
(see STIF, below). The FALSE stack should already have a 0
pushed onto it. STATE should contain LASTTRUE -- meaning that
the whole expression wants to fall through on TRUE.
SUBTTL Gbol
TRUE __SP ;TRUE FIXUP PDP
FALSE __PNT2 ;FALSE FIXUP PDP
NXTFIX __TBITS2 ;THIS IS THE NEXT FIXUP CONTEMPLATED.
STATE __SBITS2 ;THE STATE OF THINGS:
;INVERT,,AND!OR.
GBOL: MOVE A,$DATA(LPSA) ;A TERMINAL?
TLNN STATE,MOSTTRUE ;COPY MOSTTRUE INTO METRUE
TLZA STATE,METRUE ;METRUE IS BEING FILLED WITH THE
TLO STATE,METRUE ;FALL-THROUGH CONDITIONS FOR THIS
;NODE, WHETHER A TERMINAL OR NOT
TRNE A,-1 ;IS THERE A RIGHT BROTHER?
JRST .+4 ;YES -- WE HAVE ALREADY DONE THE RIGHT THING.
TLNN STATE,LASTTRUE ;COPY LASTTRUE INTO METRUE
TLZA STATE,METRUE ;SINCE THERE IS NO RIGHT BROTHER, THIS
TLO STATE,METRUE ;NODE IS THE "LAST" OF THE DESCENDANTS. HENCE
;USE THE "LAST" TEST CONDITIONS.
JUMPGE A,GTERM ;IT IS A TERMINAL NODE.
PUSH P,STATE ;SAVE IN PREPARATION FOR RECURSION
PUSH P,LPSA ;SAVE OLD POINTERS
TLNE A,GBNOT ;IS THE CURRENT NODE A "NOT"
TLC STATE,GINVRT ;COMPLEMENT INVERTING TYPES.
TLZ STATE,FLSFIX!TRUFIX
HLRZ TEMP,A ;TYPE BITS
ANDI TEMP,GBAND!GBOR ;CONNECTIVES ONLY
TLNE STATE,GINVRT ;ARE WE CURRENTLY INVERTING?
TRC TEMP,GBAND!GBOR ;YES -- CHANGE THE SENSE OF THE NODE.
;; #RT# COPY METRUE TO LASTTRUE ALWAYS, WHETHER WE ITERATE OR RECURSE
TLNN STATE,METRUE ;COPY METRUE INTO LASTTRUE
TLZA STATE,LASTTRUE ;THAT IS, THE REQUIREMENTS ON THIS
TLO STATE,LASTTRUE ;NODE ARE TO BE PASSED DOWN.
;; #RT#
CAIN TEMP,(STATE) ;SAME AS HIS FATHER?
JRST LSON ;YES -- JUST GO CALL RECURSIVELY
HRR STATE,TEMP ;NO -- RECORD THE NEW TYPES.
TRNN STATE,GBAND ;IF THE THING IS AN "OR", THEN
TLZA STATE,MOSTTRUE ;MOST GUYS ARE FALSE.
TLO STATE,MOSTTRUE ;ELSE MOST ARE TRUE.
;; INSTRUCTIONS AT #RT# ABOVE USED TO BE HERE
;;;;; TLNN STATE,METRUE ;COPY METRUE INTO LASTTRUE
;;;;; TLZA STATE,LASTTRUE ;THAT IS, THE REQUIREMENTS ON THIS
;;;;; TLO STATE,LASTTRUE ;NODE ARE TO BE PASSED DOWN.
TLNN STATE,METRUE ;IF FALL THROUGH ON FALSE AND
TRNN STATE,GBAND ; AN "AND" OPERATION, THEN
JRST LAA
PUSH FALSE,[0] ;START A NEW FALSE FIXUP
TLO STATE,FLSFIX ;AND INDICATE SO.
JRST LSON
LAA: TLNE STATE,METRUE ;IF FALL THROUGH ON TRUE AND
TRNN STATE,GBOR ; AN "OR" OPERATION, THEN
JRST LSON
PUSH TRUE,[0] ;START A NEW TRUE FIXUP
TLO STATE,TRUFIX ;AND RECORD THE FACT.
LSON:
HRRZ LPSA,$DATA2(LPSA) ;GET LEFT SON.
PUSHJ P,GBOL ;RECURSIVE CALL.
POP P,LPSA ;RESTORE OLD TREE POINTER
TLNN STATE,TRUFIX ;WAS A TRUE FIXUP EMITTED?
JRST LBB ;NOPE
POP TRUE,B
JRST FXTO ;FIXUP TO DOOOOO.
LBB: TLNN STATE,FLSFIX ;A FALSE FIXUP?
JRST LRBRT ;NO -- NONE
POP FALSE,B
FXTO: HLR B,NXTFIX ;PUT IN THE PCNT OF WHERE THE JUMP GOES.
PUSHJ P,FBOUT ;EMIT ONE HIGH-QUALITY FIXUP.
;;;;; SETZM NXTFIX ;WE DO NOT RESTART THE FIXUP LOCATION, SINCE
;WE MAY HAVE TO TERMINATE SEVERAL FIXUP
;ENTRIES ON THE STACK HERE.
;CONSIDER A OR(B AND C AND(D OR E)) -- TWO TRUE
;FIXUPS ARE STARTED WHICH WANT TO TERMINATE AT THE
;VERY END.
LRBRT: POP P,STATE ;RESTORE STATE
JRST LRBRO ;AND GO ITERATE OR EXIT
GTERM: PUSH P,STATE ;BECAUSE WE WILL CHANGE IT.
; MOVE A,$DATA(LPSA) ;XWD GBNOT(IF ON),,POINTER TO RIGHT BORTH.
TLZE A,GBNOT ;IN CASE NOT AT PRIMARY LEVEL.
TLC STATE,GINVRT
MOVE C,$DATA4+1(LPSA) ;PCNT OF FIRST,, #INSTRS
MOVSI TEMP,-1(C) ;DISPLACEMENT TO LAST INSTR OF THIS BLOCK
ADD C,TEMP ;PCNT OF LAST,, #INSTRS
MOVE NXTFIX,C ;SAVE IN NXTFIX
TLNE STATE,METRUE ;IF FALL THROUGH ON TRUE, THEN USE
EXCH C,(FALSE) ;FALSE FIXUP.
TLNN STATE,METRUE
EXCH C,(TRUE) ;PROLIFERATE THE RIGHT FIXUP CHAIN.
TLNE STATE,GINVRT
TLC STATE,METRUE ;NOW STATE TELLS WHETHER TO INVERT THE
LDB TEMP,[POINT 6,$DATA4+3(LPSA),5];MAJOR OPCODE OF 2ND INSTR
TLNE STATE,METRUE ;COMPARES
JRST NOINVRT
;;#UB# SUPERSEDED BY INTELLIGENT CODE
MOVSI D,(1B6) ;THIS IS THE BIT
XORM D,$DATA4+2(LPSA) ;WHICH SAYS, INVERT THE SENSE OF THE SKIP
CAIN TEMP,<JRST>-=30
JRST GTERM1 ;DONT MODIFY JRST'S
CAIE TEMP,<JUMP>-=30
TLO D,(1B7) ;DOUBLE SKIP, CAM ALSO CHANGE THIS BIT
XORM D,$DATA4+3(LPSA)
GTERM1:
;; LDB D,[POINT 3,$VAL(LPSA),8]
;;#UB# ! USED TO BE A MOVE
;; HRRZ D,CONVS(D) ;INVERT SENSE!
;; DPB D,[POINT 3,$VAL(LPSA),8]
NOINVRT:
CAIN TEMP,<JUMP>-=30
JRST [HLRM C,$DATA4+2(LPSA) ;END OF FIXUP IS 1ST INSTR
MOVSI TEMP,(<1B3>) ; OF DOUBLE JUMP-JUMP
IORM TEMP,$DATA4(LPSA) ;ASSUME RELOC
TLNN C,-1 ;IF FIXUP WAS 0
ANDCAM TEMP,$DATA4(LPSA) ;THEN CLEAR RELOC BIT
JRST NOINV1]
HLRM C,@$DATA3(LPSA) ;STORE FIXUP IN R.H. OF LAST CODE WORD
TLNN C,-1 ;WAS FIXUP 0?
TDZA TEMP,TEMP ;YES
MOVEI TEMP,1 ;NO
DPB TEMP,$DATA2(LPSA) ;PROPER RELOC BIT, LAST WORD
NOINV1: HLRZS $DATA4+1(LPSA) ;0,,PCNT
ADDI NXTFIX,1 ;+1 FOR PCNT WD
HRRZM NXTFIX,$DATA3(LPSA) ;#WORDS WHICH FOLLOW IN LOADER BLOCK
MOVSI TEMP,1
HLLM TEMP,$DATA3(LPSA) ;TYPE OF THIS LOADER BLOCK IS 1 (CODE)
ADD NXTFIX,TEMP ;NXTFIX POINTS TO INST AFTER TST/JRST
MOVEI B,$DATA3(LPSA) ;ADDRESS OF THIS LOADER BLOCK
PUSHJ P,GBOUT ;OUTPUT THE BLOCK.
POP P,STATE ;RESTORE STATE OF THINGS.
LRBRO: FREBLK ;DO NOT NEED IT NO MORE.
HRRZ LPSA,$DATA(LPSA) ;RIGHT BROTHER
JUMPN LPSA,GBOL ;ITERATE IF THERE IS ONE.
POPJ P, ;EXIT IF NOT.
SUBTTL If-Generators
DSCR STIF, EXIF, EXIF1, EXIF2
PRO STIF, EXIF, EXIF1, EXIF2
DES EXECS to use above De Morganizer to fixup compares and
things, keep track of TRUE addr, jump to false.
EXIF and STIF are called when the construct
"IF boolean expression THEN" is recognized. They merely
call GBOL and save the resulting fixup in the Semantic stack.
EXIF1 gets the "true" expression the the accumulator.
The accumulator number was saved in the semantic stack.
EXIF2 makes sure the types match, then gets the second expression
into the AC. A fixup is also written.
The syntactic contexts are:
SIF BE THEN drarrow SIFC STIF
EIF BE THEN drarrow EIFC EXIF
EIFC E ELSE EXIF1
EIFC E ELSE E SG drarrow E SG EXIF2
^EXIF:
^STIF:
PUSHJ P,FRBT ;FORCE ALL BINARY OUT.
MOVE LPSA,GENLEF+1 ;CHECK FOR CONSTANT BE
MOVE A,$DATA(LPSA)
TLNN A,BOLCON ;WELL?
JRST STIFF ;NO
FREBLK ;DON'T NEED THE CONSTANT
MOVNI B,1 ;ASSUME TRUE, NO <JRST FALSE> FIXUP
TLNN A,FLSCON ;WELL?
JRST PTWAY ;RIGHT FOR ONCE, NO CODE
HRL B,PCNT ;ISSUE <JRST FALSE> TO DISABLE TRUE
EMIT (<JRST NOUSAC!NOADDR>)
JRST PTWAY
STIFF: MOVE TRUE,[IOWD BPDL,TRPDL]
MOVE FALSE,[IOWD BPDL,FAPDL]
MOVSI STATE,LASTTRUE ;FALL THROUGH ON TRUE !!!!!!
PUSH FALSE,[0] ;NEW FALSE FIXUP TO PLAY WITH.
MOVE LPSA,GENLEF+1 ;SEMANTICS OF BOOLEAN TREE
SETPOV (FALSE,DRYROT -- BOOLEAN EXPRESSION STACKS)
SETPOV (TRUE,DRYROT -- BOOLEAN EXPRESSION STACKS)
PUSHJ P,GBOL ;EVALUATE THE BOOLEAN CODE
SETPOV (FALSE,) ;DISABLE THIS ONE
; TRUE__SP
SETPOV (TRUE,PARSE STACKS -- USE /R TO INCREASE)
MOVE B,(FALSE) ;FALSE FIXUP
PTWAY: HLLM B,GENRIG ;SAVE IT.
;;#ST# ! RHT NEEDED TO DO AN ALLSTO
JRST ALLSTO
^EXIF1: SOJL B,.+3
JUMPN B,LPEXF1 ;..LEAP..
PUSHJ P,LEVBOL ;LEAVE BOOLEAN MODE.
;AND FALL THROUGH.....
BAIL<
SKIPLE BAILON
PUSHJ P,BCROUT ;A NEW COORDINATE FOR AN ELSE
>;BAIL
GETSEM (1) ;SEMANTICS OF EXPRESSION
TRNE TBITS,STRING
JRST [GENMOV (STACK,MRK)
MOVNI A,2
ADDM A,SDEPTH ;SINCE WE ARE GOING TO JRST.
JRST EXIF12]
GENMOV (GET,POSIT!REM)
EXIF12: MOVEM TBITS,GENRIG+1 ;AND SAVE EXPRESSION SEMANTICS.
HRRM D,GENRIG+2 ;SAVE ACCUMULATOR NUMBER.
PUSHJ P,ALLSTO ;SAME REASON AS CITED ABOVE.
;THE RESON FOR THE ALLSTO IS SOMETHING LIKE:
; IF I_J+1>1 THEN <COMPLICATED EXPR WHICH FORCES I TO STORE>
; ELSE <COMPLICATED EXPR WHICH USES I!!>
;
HRL PNT2,PCNT ;PRESENT PROGRAM COUNTER (FOR FALSE EXPTR.)
HLL B,GENLEF+2 ;FALSE FIXUP
HLLM PNT2,GENRIG+2 ;FIXUP FOR JRST
MOVE A,[JRST NOADDR+NOUSAC]
PUSHJ P,EMITER
;;#HG#2! 5-14-72 DCS (1-4) TEST ENTIRE LEFT HALF (OR /H DOESN'T WORK)
HLRE TEMP,B ;IF LEFT HALF IS -1,
AOJE TEMP,CPOPJ ; NOBODY JUMPED HERE, SO DON'T FIX IT UP
HRR B,PCNT ;PREPARE THE FIXUP FOR "FALSE"
JRST FBOUT ;FIXUP AND DONE.
^EXIF2: SOJL B,.+3
JUMPN B,LPEXF2 ;..LEAP..
PUSHJ P,LEVBOL ;LEAVE BOOLEAN MODE, AND
;FALL THROUGH.
GETSEM (1) ;THE SECOND EXPRESSION.
HRRZ D,GENLEF+4 ;THIS IS THE AC NUMBER WE HAVE RESERVED.
HRRI FF,POSIT!SPAC!REM
HRRZ B,GENLEF+3 ;TYPE BITS FROM FIRST GUY.
CAIE B,(TBITS) ;THE SAME TYPES?
TRO FF,INSIST ;NO
TRNE B,STRING
JRST [TRZ FF,REM ; DON'T REMOP AS PART OF PRE AS
GENMOV (STACK) ; STACK WILL DO IT NORMALLY
;;#MK ! MAKE SURE THAT WE GET A BRAND NEW TEMP AT MARK1 BELOW SINCE THIS REMOPPED
SETZM SBITS
JRST .+2]
GENMOV (GET) ;GO GET THE ARGUMENT IN THE AC.
; PUSHJ P,REMOP ;GOT TO RELEASE IT SO THAT
PUSHJ P,ALLSTO ;ALLSTO WON'T FIND IT.
HRR B,PCNT
HLL B,GENLEF+4 ;TRUE FIXUP
PUSHJ P,FBOUT ;EMIT THE FIXUP.
;;#WO# JFR 4-1-76 RECORD!POINTER conditional expressions got DRYROT at MARK
; because RCLASS was zero
TRNN TBITS,PNTVAR ;RECORD!POINTER?
JRST EXI.21 ;NO
HLRZ TEMP,$ACNO(PNT) ;CLASS INFO FROM POINTER
SKIPN RCLASS ;DONT'T MUNGE IF SOMEHOW OK
MOVEM TEMP,RCLASS ;SAVE THE WORLD FROM DRYROT AT MARK
EXI.21:
;;#WO# ^
JRST MARK1 ;GENMOV(MARK) ; MOVEM PNT,GENRIG+1
DSCR IFLS1, IFNLS, IFLS2
PRO IFLS1 IFNLS IFLS2
These are the routines for the statement level IF
generation.
IFLS1 is called when the "else" following an IF xx THEN is
seen. It outputs a jrst, and a fixup.
IFNLS is called if we see IF xx THEN ; . It merely outputs
a fixup.
IFLS2 is called when the statement after the ELSE is
finished. It merely outputs a fixup.
The syntactic contexts are:
SIFC S ELSE IFLS1
SIFC S @END drarrow S @END IFNLS
SIFC S ELSE S @END drarrow S @END IFLS2
^IFLS1: PUSHJ P,ALLSTO ;STORE EVERYONE IRREVOCABLY.
MOVE A,PCNT
HRLM A,GENRIG+2 ;NEW FIXUP
MOVE A,[JRST NOADDR+NOUSAC]
PUSHJ P,EMITER ;EMIT THE JRST AROUND FALSE PART.
BAIL<
SKIPLE BAILON
PUSHJ P,BCROUT ;A NEW COORDINATE FOR EACH ELSE
>;BAIL
SKIPA
^IFLS2: SKIPA B,GENLEF+4
^IFNLS: MOVE B,GENLEF+2
PUSHJ P,ALLSTO ;STORE EVERYONE.
;;#HG#2! 5-14-72 DCS (2-4) TEST ENTIRE LEFT HALF
HLRE TEMP,B ;IF LEFT HALF IS -1, THEN
AOJE TEMP,CPOPJ ; NOBODY JUMPED HERE, SO DON'T FIX UP
HRR B,PCNT
JRST FBOUT ;EMIT THE FIXUPS.
SUBTTL BE to P Coercion
;THIS IS THE LAST RESORT. A BOOLEAN EXPRESSION WANTS TO BE
;STORED, OR PASSED TO A PROCEDURE, OR SOMETHING.
;SO WE HAPPILY MAKE UP A NUMBER.
^LEVBOL:ERR <DRYROT -- SOMETHING EXPOP DIDN'T CATCH>,1
PUSHJ P,EXPOP
MOVE PNT,GENRIG+1
MOVEM PNT,GENLEF+1
POPJ P,
^^EXPOP1:
MOVE TEMP,GENLEF+2 ;NEED ONE VALUE, FROM GENLEF+1
MOVEM TEMP,GENLEF+1 ;FOR ALL OTHERS OF THIS ILK.
^^EXPOP:MOVE LPSA,GENLEF+1 ;LOOK FOR CONSTANT BE
MOVE A,$DATA(LPSA)
TLNN A,BOLCON ;TRUE OR FALSE?
JRST EXPOP2 ;YES, BUT DON'T KNOW WHICH
FREBLK ;DON'T NEED CONSTANT
TLNN A,TRUCON ;TRUE?
TDZA A,A ;NO, FALSE
MOVNI A,1 ;YES, TRUE
MOVEM A,SCNVAL
PUSHJ P,CREINT ;IT'S JUST A NUMBER
MOVEM PNT,GENRIG+1
POPJ P,
EXPOP2: PUSHJ P,BONOT ;INVERT ALL THE TESTS
PUSHJ P,STIF ;GO EVALUATE -- LH OF GENRIG HAS FIXUP.
PUSHJ P,GETAN0
HRL C,D ;USE AS AC AND ADDR
; FALSE (BECAUSE IF INVERSION ABOVE) VALUE
EMIT (<TDZA NORLC!USADDR>)
; MOVE B,GENRIG ;FIXUP FOR TRUE (BECAUSE OF INVERSION)
HRR B,PCNT
PUSHJ P,FBOUT ;EMIT FIXUP.
HRLI C,1
EMIT <MOVNI USADDR!NORLC>
PUSHJ P,MARKINT ;MARK AN INTEGER.
MOVEM PNT,GENRIG+1 ;AND RECORD RESULT
POPJ P,
^^CHKCON:GETSEM (1) ;SEMANTICS OF EXPRESSION
TLNN TBITS,CNST ;MUST BE A CONSTANT
ERR <SAIL REQUIRES A CONSTANT EXPRESSION HERE>,1
POPJ P,
^^TWID21:MOVE TEMP,GENLEF+2 ;THIS SHOULD BE IN GEN
MOVEM TEMP,GENRIG+1
POPJ P,
BEND BOOLEAN
LIT
SUBTTL For Loop and While Generators.