perm filename EXPRS[S,AIL]26 blob
sn#210231 filedate 1976-04-12 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00023 PAGES VERSION 17(17)
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 HISTORY
C00009 00003 Binary Operators
C00012 00004
C00020 00005 Constant Binary Operators ----- Gtarts
C00022 00006 Unary Operators
C00025 00007 Exponentiation Code!
C00033 00008 Strings -- Concatenation
C00039 00009 Substring, Length, Lop
C00044 00010 Point, Ldb, Ildb, Dpb, etc.
C00051 00011 Swap Operator.
C00057 00012 Store Operator
C00063 00013 Booleans -- Description
C00067 00014 Variables
C00070 00015 Arith TO Relop
C00073 00016 Relational Operators
C00081 00017 Connectives, Negation
C00085 00018 Constant Connectives
C00088 00019 Gbol -- Discussion
C00092 00020 Gbol
C00100 00021 If-Generators
C00107 00022
C00109 00023 BE to P Coercion
C00112 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,
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
MXMNTB: CAMGE (<CAMGE>) ; MAX (COMMUTATIVE,
CAMLE (<CAMLE>) ; MIN TYPELESS)
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 1 -- of ACcumulator field indicates needs immediate operand.
Bit 2 -- NO type conversions necessary **** ???
Bit 4 -- INSIST on REAL 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
JRST PLSMDO ;USE COMMON BINARY OP CODE
;;%##%
↑TIMDIV: CAIL B,10 ;IS THIS THE STRING OPERATOR & ?
JRST CONCAT ;YES
SKIPA C,TDTAB(B) ;PICK UP OPERATOR
↑PLUSM: MOVE C,PMTAB(B) ;FOR PLUS OR MINUS , ETC.
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
HRRI FF,ARITH!POSIT!BITS2 ;JUST INSIST ON ARITH ARG IF
TLNE C,100 ;NO CONVERSIONS TO DO?
JRST TPGO
MOVEI B,INTEGR
TLNE C,200 ;DO WE REQUIRE REAL ARGS.?
MOVEI B,FLOTNG ;YES
HRRI FF,INSIST!POSIT!BITS2 ;GOING TO INSIST FROM NOW ON.
TLNE C,202 ;DO WE REQUIRE BOTH ARG'S FIXED?
JRST TPGO ;YES.
TPCHK: TRNN TBITS,FLOTNG
TRNE TBITS2,FLOTNG ;IF EITHER ARE FLOTING, DO
JRST [MOVSS OPCODE ;SOME IMPORTANT THINGS.
MOVEI B,FLOTNG ;PREPARE FOR GENMOV.
JRST .+1]
TPGO:
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
GENMOV (ACCESS,PROTECT!UNPROTECT) ;GET ACCESS TO SECOND OPERAND.
HLLZ A,OPCODE ;ALL READY TO GO TO EMITER.
TLZ A,737 ;TURN OFF CONTROVERSIAL BITS.
TLZE A,40
JRST [TRO A,USADDR!NORLC ;PREPARE FOR CONSTANT OPERAND.
HRL C,$VAL(PNT) ;VALUE
TLNE TBITS,CNST ;WERE WE JUSTIFIED?
JRST .+1 ;YES
PUSH P,A ;THIS IS FOR ROT AND LSH, ETC.
HRLS D ;WE WANT A NEW ACCUMULATOR.
GENMOV (GET,INDX!POSIT!PROTECT);WHILE WE PROTECT THIS ONE
MOVSS D ;SWAP BACK FOR THE OPERATION.
HRRZS ACKTAB (D) ;UNPROTECT ARG1'S
POP P,A ;FOR THE OP CODE.
HRRI A,USX!NOADDR
JRST .+1]
EMGOX: PUSHJ P,EMITER ;DO THE EMIT. !! AN ARITHMETIC INSTRUCTION !!
EXIT: MOVE A,OPCODE
TLNE A,4 ;IS IT "MOD"
JRST [PUSHJ P,CLEARA ;YES -- THIS AC HAS BEEN CHANGED.
ADDI D,1 ;YES--MARK THE SECOND ACCUMULATOR
JRST .+1]
MOVS TEMP,A ;IF MAX OR MIN, BOTH HALVES ARE
CAMN TEMP,A ;EQUAL, THIS DETECTS IT
JRST [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!
PUSHJ P,REMOP ;REMOP THE FIRST ARGUMENT,
PUSHJ P,REMOP2 ;AND THE SECOND.
TLNN 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 ----- Gtarts
ALLCON: HLLZ A,OPCODE
HRRI A,$VAL(PNT2) ;ADDRESS OF ARGUMENT.
TLNE A,40 ; NEED IMMEDIATE OPERAND?
HRR A,$VAL(PNT2) ; YES.
TLZA A,777
GETC: HLR A,C ;GET THE IMMEDIATE RESULT FROM OPCHK.
SKIPA B,$VAL(PNT) ;THE FIRST ARGUMENT.
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?
JRST [JUMPN TEMP,.+1 ;SKIPPED, VALUE OK
MOVE B,$VAL(PNT2) ;NO SKIP, ANS IS THIS ONE
JRST .+1]
MOVEM B,SCNVAL ;RESULT
TRNE A,4 ;A "MOD"
MOVEM C,SCNVAL
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
UNOT: SKIPA A,[SETCM POSIT]
UNABS: MOVSI A,(<MOVM>)
UGOO: MOVEM A,OPCODE
TLNE TBITS,CNST ;A CONSTANT?
JRST ALCON1 ;USE ARITHMETIC CONSTANT FOR EXIT.
GETAB: HRRZ D,$ACNO(PNT) ;GET AC NUMBER
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>)
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
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]
MOVE A,[MOVEI USADDR!NORLC]
MOVSI C,1
TRNE TBITS,INTEGR ;ARGUMENT INTEGER?
JRST FXDEX ;YES -- ALL SET.
HRLI SP,(<FMP>)
HRLI A,(<MOVSI>)
HRLI C,(1.0)
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,EXMRK ;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 EXMRK
NOASH:
PUSHJ P,GETAC
PUSHJ P,EMITER ;MOVEI AC1,1
SKIPN B ;EXPONENT ZERO?
JRST EXMRK ;YES -- ALL DONE.
PUSH P,D
SETOM ACKTAB(D)
GENMOV (GET,POSIT) ;GET ARGUMENT.
HRL C,D
POWLUP: MOVE A,SP
HRR D,(P)
TRNE B,1 ;OUTPUT THE IMUL ?
PUSHJ P,EMITER ;IMUL AC1,AC2
HLR D,C
ASH B,-1
JUMPE B,POWDUN
MOVE A,SP
PUSHJ P,EMITER ;IMUL AC2,AC2
JRST POWLUP
POWDUN: POP P,D
SETZM ACKTAB(D)
EXMRK: 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
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 <0↑0 NOT DEFINED>,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,INTEGR
PUSHJ P,POW
TRNE TBITS2,FLOTNG
PUSHJ P,LOGS
JRST RETREL ;RETURN A REAL
;BASE IS REAL, LOOK AT EXPONENT
RELBAS:
TRNE TBITS2,INTEGR
PUSHJ P,FPOW
TRNE TBITS2,FLOTNG
PUSHJ P,FLOGS
RETREL:
MOVE TBITS,[XWD CNST,FLOTNG] ;MARK AS FLOTNG
MOVEM TBITS,BITS ;FOR CONINS LATER.
MOVEM 1,SCNVAL ;AND THE VALUE GENERATED.
PUSHJ P,CONINS ;WATCH THE MAGIC.
JRST PUT1 ;MOVEM PNT,GENRIG+1 ; POPJ P,
EXRTN1: EXCHOP
EXROUT: GENMOV (STACK,ARITH) ;STACK THE EXPONENT.
GENMOV (STACK,EXCHIN!ARITH) ;AND THE ARGUMENT.
XPREP
MOVNI A,2
ADDM A,ADEPTH ;TO READJUST STACKS.
TRNN TBITS2,INTEGR ;ARGUMENT 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.
STACKM: GENMOV (STACK,EXCHOUT) ;One (or both) ¬string, or arg1 stacked, or
GENMOV (STACK,0) ; arg2 ¬stacked -- be sure both are stacked.
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
;; #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.
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.
↑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.
$ACNO xwd pcnt of first instr of compare,type
(type = 1 for a jumpxx, =2 for a camxx jrst)
$ADR xwd relocation bit for first word of code,bit for second
$VAL first word of code as emitted.
$VAL2 second word of code as emitted.
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
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
⊗
;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
GETBLK <GENRIG+1> ;GET A FREE STORAGE BLOCK AND ATTACH TO
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,TRUCON ;ASSUME TRUE
SKIPN $VAL(PNT)
FL: MOVSI TEMP,FLSCON ;ASSUMPTION INVALID
TR: 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
GETBLK <GENRIG+1> ;GET A FREE STORAGE BLOCK FOR BOOLEAN PURPOSES.
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,FLOTNG ;IF THEY DON'T AGREE.
TRNN TBITS2,FLOTNG
TRNE TBITS,FLOTNG ;IF EITHER FLOTING, MAKE BOTH
TRC FF,INSIST!ARITH ;FLOTING.
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
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,TRUCON;ASSUME TRUE
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: HRR C,CONVT(C) ;REVERSE ORDER OF COMPARE
JRST BGET
BGOOD: TLC C,1 ;INDICATE THAT ONE EXCHOP IS DONE.
EXCHOP
BGET: TLNE TBITS2,CNST ;IS THE SECOND ARG. A CONSTANT?
SKIPE $VAL(PNT2) ;IS THE VALUE ZERO ALSO.
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# -- 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]
PUSHJ P,EMITER ;EMIT THE JUMPxx.
MOVE A,[XWD 1,$VAL]
JRST BODON3 ;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]
JRST BFIN ;FINISH OUT AS WITH CAM.
BGOT: GENMOV (GET,POSIT!BITS2!EXCHOUT);MAKE SURE ACCUMULAOR IS FULL.
TLC C,1 ;INDICATE ANOTHER EXCHOP DONE.
GENMOV (ACCESS,0) ;MAKE SURE WE ARE SAFE.
HRLZI A,(<CAM>) ;THE COMPARE OPERATION!
BFIN: TRO A,USCOND ;INDICATE "C" CONTAINS CONDITION BITS.
PUSHJ P,EMITER
MOVE A,[XWD 2,$VAL] ;MARK THE STORAGE BLOCK WITH THIS CODE.
PUSHJ P,BODON
MOVE A,[JRST NOADDR+NOUSAC] ;THE FOLLOWING JRST.
PUSHJ P,EMITER
MOVE A,[XWD 2,$VAL2]
BODON3: 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.
MOVE TEMP,LSTRLC ;RELOCATION BIT OF LAST WORD EMITTED.
TRNE A,$VAL2 ;IS THIS THE FIRST WORD?
JRST BSEC ;NO
HLRM A,$ACNO(LPSA)
MOVE B,PCNT
SUBI B,1 ;TO GET THE REAL PCNT.
HRLM B,$ACNO(LPSA) ;XWD PCNT,TYPE OF COMPARE.
HRLM TEMP,$ADR(LPSA) ;RELOCATION FOR FIRST WORD.
TRNA
BSEC: HRRM TEMP,$ADR(LPSA) ;RELOCATION FOR SECOND WORD.
ADDI A,(LPSA) ;COMPUTE PLACE TO PUT
MOVE B,LSTWRD ;THE LAST WORD OF CODE GENERATED.
MOVEM B,(A)
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
MOVE B,[JUMP NOUSAC!NOADDR];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
MOVE B,[JUMPA NOUSAC!NOADDR];YES, JUMP-ALWAYS TO FALSE PART
ONEOUT: HLLZM B,$VAL(USER) ;THE INSTRUCTION ISSUED
HRL TEMP,PCNT
HRRI TEMP,1 ;PCNT OR JUMP,,JUMP ONLY
MOVEM TEMP,$ACNO(USER)
SETZM $ADR(USER) ;NO RELOCATION
SETZM $DATA(USER) ;NO BROTHERS, NO TYPE BITS
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,$ACNO(LPSA) ;PCNT,,TYPE
MOVE NXTFIX,C ;SAVE IN NXTFIX
TRNE C,2 ;IF IT IS A TWO-WORD OPERATION,
AOBJP C,.+1 ;WE ARE INTERESTED IN THE SECOND WORD.
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
TLNE STATE,METRUE ;COMPARES
JRST NOINVRT
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:
HLRM C,$VAL2(LPSA) ;STORE FIXUP
TRNE NXTFIX,1 ;A ONE-WORD OPERATION?
HLRM C,$VAL(LPSA) ;YES
MOVS TEMP,$ADR(LPSA)
DPB TEMP,[POINT 1,BRELC,3] ;RELOCATION BITS.
MOVE TEMP,$VAL(LPSA) ;FIRST WORD OF COMPARE
MOVEM TEMP,BWRD1 ;FIRST WORD IN OUTPUT BLOCK.
MOVSI USER,(<1B3>) ;ANOTHER RELOACTION BIT.
TRNE NXTFIX,1 ;ONE WORD?
JRST WOUT ;YES
MOVE TEMP,$VAL2(LPSA) ;SECOND WORD.
MOVEM TEMP,BWRD2
MOVSI USER,(<1B5>) ;RELOCATION BIT FOR THIS WORD.
WOUT: IORM USER,BRELC ;TURN IT ON (TENTATIVELY)
TRNN TEMP,-1 ;IS THE FIXUP ZERO?
ANDCAM USER,BRELC ;YES -- TURN OFF THE BIT.
HLRZM NXTFIX,BPCNT ;PROGRAM COUNTER
ADDI NXTFIX,1 ;TO ACCOUNT FOR PCNT WORD.
HRRM NXTFIX,BOLOUT ;COUNT
MOVEI B,BOLOUT
PUSHJ P,GBOUT ;OUTPUT THE BLOCK.
HRLZI C,-1(NXTFIX) ;COUNT OF WORDS.
ADD NXTFIX,C ;NXTFIX POINTS TO INST AFTR TST/JRST.
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
SUBTTL For Loop and While Generators.