C*********************************************************************** C C 8 0 8 0 P L / M C O M P I L E R , P A S S - 2 C PLM82 C VERSION 2.0 C JANUARY, 1975 C C COPYRIGHT (C) 1975 C INTEL CORPORATION C 3065 BOWERS AVENUE C SANTA CLARA, CALIFORNIA 95051 C C MODIFYED BY JEFF OGDEN (UM), DECEMBER 1977. C C*********************************************************************** C C C P A S S - 2 E R R O R M E S S A G E S C C ERROR MESSAGE C NUMBER C ------ --- ------------------------------------------------------- C C 101 REFERENCE TO STORAGE LOCATIONS OUTSIDE THE VIRTUAL MEMORY C OF PASS-2. RE-COMPILE PASS-2 WITH LARGER 'MEMORY' ARRAY. C C 102 " C C 103 VIRTUAL MEMORY OVERFLOW. PROGRAM IS TOO LARGE TO COMPILE C WITH PRESENT SIZE OF 'MEMORY.' EITHER SHORTEN PROGRAM OR C RECOMPILE PASS-2 WITH A LARGER VIRTUAL MEMORY. C C 104 (SAME AS 103). C C C 105 $TOGGLE USED IMPROPERLY IN PASS-2. ATTEMPT TO COMPLEMENT C A TOGGLE WHICH HAS A VALUE OTHER THAN 0 OR 1. C C 106 REGISTER ALLOCATION TABLE UNDERFLOW. MAY BE DUE TO A PRE- C C 107 REGISTER ALLOCATION ERROR. NO REGISTERS AVAILABLE. MAY C BE CAUSED BY A PREVIOUS ERROR, OR PASS-2 COMPILER ERROR. C C 108 PASS-2 SYMBOL TABLE OVERFLOW. REDUCE NUMBER OF C SYMBOLS, OR RE-COMPILE PASS-2 WITH LARGER SYMBOL TABLE. C C 109 SYMBOL TABLE OVERFLOW (SEE ERROR 108). C C 110 MEMORY ALLOCATION ERROR. TOO MUCH STORAGE SPECIFIED IN C THE SOURCE PROGRAM (16K MAX). REDUCE SOURCE PROGRAM C MEMORY REQUIREMENTS. C C 111 INLINE DATA FORMAT ERROR. MAY BE DUE TO IMPROPER C RECORD SIZE IN SYMBOL TABLE FILE PASSED TO PASS-2. C C 112 (SAME AS ERROR 107). C C 113 REGISTER ALLOCATION STACK OVERFLOW. EITHER SIMPLIFY THE C PROGRAM OR INCREASE THE SIZE OF THE ALLOCATION STACKS. C C 114 PASS-2 COMPILER ERROR IN 'LITADD' -- MAY BE DUE TO A C PREVIOUS ERROR. C C 115 (SAME AS 114). C C 116 (SAME AS 114). C C 117 LINE WIDTH SET TOO NARROW FOR CODE DUMP (USE $WIDTH=N) C C 118 (SAME AS 107). C C 119 (SAME AS 110). C C 120 (SAME AS 110, BUT MAY BE A PASS-2 COMPILER ERROR). C C 121 (SAME AS 108). C C 122 PROGRAM REQUIRES TOO MUCH PROGRAM AND VARIABLE STORAGE. C (PROGRAM AND VARIABLES EXCEED 16K). C C 123 INITIALIZED STORAGE OVERLAPS PREVIOUSLY INITIALIZED STORAGE. C C 124 INITIALIZATION TABLE FORMAT ERROR. (SEE ERROR 111). C C 125 INLINE DATA ERROR. MAY HAVE BEEN CAUSED BY PREVIOUS ERROR. C C 126 BUILT-IN FUNCTION IMPROPERLY CALLED. C C 127 INVALID INTERMEDIATE LANGUAGE FORMAT. (SEE ERROR 111). C C 128 (SAME AS ERROR 113). C C 129 INVALID USE OF BUILT-IN FUNCTION IN AN ASSIGNMENT. C C 130 PASS-2 COMPILER ERROR. INVALID VARIABLE PRECISION (NOT C SINGLE BYTE OR DOUBLE BYTE). MAY BE DUE TO PREVIOUS ERROR. C C 131 LABEL RESOLUTION ERROR IN PASS-2 (MAY BE COMPILER ERROR). C C 132 (SAME AS 108). C C 133 (SAME AS 113). C C 134 INVALID PROGRAM TRANSFER (ONLY COMPUTED JUMPS ARE ALLOWED C WITH A 'GO TO'). C C 135 (SAME AS 134). C C 136 ERROR IN BUILT-IN FUNCTION CALL. C C 137 (NOT USED) C C 138 (SAME AS 107). C C 139 ERROR IN CHANGING VARIABLE TO ADDRESS REFERENCE. MAY C BE A PASS-2 COMPILER ERROR, OR MAY BE CAUSED BY PRE- C VOUS ERROR. C C 140 (SAME AS 107). C C 141 INVALID ORIGIN. CODE HAS ALREADY BEEN GENERATED IN THE C SPECIFIED LOCATIONS. C C 142 A SYMBOL TABLE DUMP HAS BEEN SPECIFIED (USING THE $MEMORY C TOGGLE IN PASS-1), BUT NO FILE HAS BEEN SPECIFIED TO RE- C CEIVE THE BNPF TAPE (USE THE $BNPF=N CONTROL). C C 143 INVALID FORMAT FOR THE SIMULATOR SYMBOL TABLE DUMP (SEE C ERROR 111). C C 144 STACK NOT EMPTY AT END OF COMPILATION. POSSIBLY CAUSED C BY PREVIOUS COMPILATION ERROR. C C 145 PROCEDURES NESTED TOO DEEPLY (HL OPTIMIZATION) C SIMPLIFY NESTING, OR RE-COMPILE WITH LARGER PSTACK C C 146 PROCEDURE OPTIMIZATION STACK UNDERFLOW. MAY BE A C RETURN IN OUTER BLOCK. C C 147 PASS-2 COMPILER ERROR IN LOADV. REGISTER C STACK ORDER IS INVALID. MAY BE DUE TO PREVIOUS ERROR. C C 148 PASS-2 COMPILER ERROR. ATTEMPT TO UNSTACK TOO C MANY VALUES. MAY BE DUE TO PREVIOUS ERROR. C C 149 PASS-2 COMPILER ERROR. ATTEMPT TO CONVERT INVALID C VALUE TO ADDRESS TYPE. MAY BE DUE TO PREVIOUS ERROR. C C 150 (SAME AS 147) C C 151 PASS-2 COMPILER ERROR. UNBALANCED EXECUTION STACK C AT BLOCK END. MAY BE DUE TO A PREVIOUS ERROR. C C 152 INVALID STACK ORDER IN APPLY. MAY BE DUE TO PREVIOUS C ERROR. C C C I M P L E M E N T A T I O N N O T E S C - - - - - - - - - - - - - - - - - - - C THE PL/M COMPILER IS INTENDED TO BE WRITTEN IN ANSI STANDARD C FORTRAN - IV, AND THUS IT SHOULD BE POSSIBLE TO COMPILE AND C EXECUTE THIS PROGRAM ON ANY MACHINE WHICH SUPPORTS THIS FORTRAN C STANDARD. BOTH PASS-1 AND PASS-2, HOWEVER, ASSUME THE HOST C MACHINE WORD SIZE IS AT LEAST 31 BITS, EXCLUDING THE SIGN BIT C (I.E., 32 BITS IF THE SIGN IS INCLUDED). C C THE IMPLEMENTOR MAY FIND IT NECESSARY TO CHANGE THE SOURCE PROGRAM C IN ORDER TO ACCOUNT FOR SYSTEM DEPENDENCIES. THESE CHANGES ARE C AS FOLLOWS C C 1) THE FORTRAN LOGICAL UNIT NUMBERS FOR VARIOUS DEVICES C MAY HAVE TO BE CHANGED IN THE 'GNC' AND 'WRITEL' SUBROU- C TINES (SEE THE FILE DEFINITIONS BELOW). C C 2) THE HOST MACHINE MAY NOT HAVE THE PL/M 52 CHARACTER SET C 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ$=./()+-'*,<>:; C (THE LAST 15 SPECIAL CHARACTERS ARE C DOLLAR, EQUAL, PERIOD, SLASH, LEFT PAREN, C RIGHT PAREN, PLUS, MINUS, QUOTE, ASTERISK, C COMMA, LESS-THAN, GREATER-THAN, COLON, SEMI-COLON) C IN THIS CASE, IT IS NECESSARY TO CHANGE THE 'OTRAN' VECTOR IN C BLOCK DATA TO A CHARACTER SET WHICH THE HOST MACHINE SUPPORTS C C 3) ALTHOUGH THE DISTRIBUTION VERSION OF PASS-2 ASSUMES A C MINIMUM OF 31 BITS PER WORD ON THE HOST MACHINE, BETTER C STORAGE UTILIZATION IS OBTAINED BY ALTERING THE 'WDSIZE' C PARAMETER IN BLOCK DATA (SECOND TO LAST LINE OF THIS PROGRAM). C THE WDSIZE IS CURRENTLY SET TO 31 BITS (FOR THE S/360), AND C THUS WILL EXECUTE ON ALL MACHINES WITH A LARGER WORD SIZE. THE C VALUE OF WDSIZE MAY BE SET TO THE NUMBER OF USABLE BITS IN C A FORTRAN INTEGER, EXCLUDING THE SIGN BIT (E.G., ON A C CDC 6X00, SET WDSIZE TO 44, AND ON A UNIVAC 1108, SET WDSIZE C TO 35). IN GENERAL, LARGER VALUES OF WDSIZE ALLOW LARGER 8080 C PROGRAMS TO BE COMPILED WITHOUT CHANGING THE SIZE OF THE C 'MEM' VECTOR. C C 4) THE HOST FORTRAN SYSTEM MAY HAVE A LIMITATION ON THE NUMBER C OF CONTIGUOUS COMMENT RECORDS (E.G. S/360 LEVEL G). IF SO, C INTERSPERSE THE DECLARATION STATEMENTS INTEGER I1000, INTEGER C I1001, ETC., AS NECESSARY TO BREAK UP THE LENGTH OF COMMENTS. C THE SYMBOLS I1XXX ARE RESERVED FOR THIS PURPOSE. C C THERE ARE A NUMBER OF COMPILER PARAMETERS WHICH MAY HAVE TO C BE CHANGED FOR YOUR INSTALLATION. THESE PARAMETERS ARE DEFINED C BELOW (SEE 'SCANNER COMMANDS'), AND THE CORRESPONDING DEFAULT C VALUES ARE SET FOLLOWING THEIR DEFINITION. FOR EXAMPLE, THE C $RIGHTMARGIN = I C PARAMETER DETERMINES THE RIGHT MARGIN OF THE INPUT SOURCE LINE. C THE PARAMETER IS SET EXTERNALLY BY A SINGLE LINE STARTING WITH C '$R' IN COLUMNS ONE AND TWO (THE REMAINING CHARACTERS UP TO C THE '=' ARE IGNORED). THE INTERNAL COMPILER REPRESENTATION C OF THE CHARACTER 'R' IS 29 (SEE CHARACTER CODES BELOW), AND THUS C THE VALUE OF THE $RIGHTMARGIN PARAMETER CORRESPONDS TO ELEMENT 29 C OF THE 'CONTRL' VECTOR. C C 1) IF OPERATING IN AN INTERACTIVE MODE, IT IS OFTEN C DESIRABLE TO MINIMIZE OUTPUT FROM PASS-2. THUS, THE FOLLOWING C PARAMETERS ARE USUALLY SET AS DEFAULTS C $TERMINAL = 1 C $INPUT = 1 C $OUTPUT = 1 C $GENERATE = 0 C $FINISH = 0 C C ALL OTHER PARAMETERS ARE THEN SELECTED FROM THE CONSOLE C C 2) IF OPERATING IN BATCH MODE, A NUMBER OF DEFAULT TOGGLES ARE C OFTEN SET WHICH PROVIDE USEFUL INFORMATION WHEN DEBUGGING C THE FINAL PROGRAM C $TERMINAL = 0 C $INPUT = 2 C $OUTPUT = 2 C $GENERATE = 1 (LINE NUMBER VS. CODE LOCATIONS) C $FINISH = 1 (DECODE PROGRAM INTO MNEMONICS AT END) C C 3) IF OPERATING WITH AN INTELLEC 8/80, IT MAY BE USEFUL TO SET C THE CODE GENERATION HEADER AT 16, PAST THE MONITOR'S VARIABLES. C $HEADER = 16 C C RECALL, OF COURSE, THAT THE PROGRAMMER CAN ALWAYS OVERRIDE THESE C DEFAULT TOGGLES -- THEY ARE ONLY A CONVENIENCE TO THE PROGRAMMER. C C 5) THE CHARACTERISTICS OF THE INTERMEDIATE LANGUAGE FILES C PRODUCED BY PASS-1 ARE MONITORED BY THE $J, $R, $U, AND C $Z PARAMETERS. THESE PARAMETERS CORRESPOND TO THE SOURCE C AND WIDTH OF THE INTERMEDIATE CODE FILE ($J AND $R), AND C SOURCE AND WIDTH OF THE INTERMEDIATE SYMBOL TABLE ($U C AND $R). SOME FORTRAN SYSTEMS DELETE THE LEADING CHARACTER C OF THE FILES PRODUCED BY OTHER FORTRAN PROGRAMS. THE $Z C PARAMETER MAY BE USED TO READ EXTRA BLANKS AT THE BEGINNING OF C THE INTERMEDIATE FILES IF THIS BECOMES A PROBLEM ON THE HOST C SYSTEM. C C UNDER NORMAL CIRCUMSTANCES, THESE PARAMETERS WILL NOT C HAVE TO BE CHANGED. IN ANY CASE, EXPERIMENT WITH VARIOUS C VALUES OF THE $ PARAMETERS BY SETTING THEM EXTERNALLY BE- C FORE ACTUALLY CHANGING THE DEFAULTS. C C THE IMPLEMENTOR MAY ALSO WISH TO INCREASE OR DECREASE THE SIZE C OF PASS-1 OR PASS-2 TABLES. THE TABLES IN PASS-2 THAT MAY BE C CHANGED IN SIZE ARE 'MEM' AND 'SYMBOL' WHICH CORRESPOND TO C THE AREAS WHICH HOLD THE COMPILED PROGRAM AND PROGRAM SYMBOL C ATTRIBUTES, RESPECTIVELY. IT IS IMPOSSIBLE TO PROVIDE AN C EXACT FORMULA WHICH RELATES THE NUMBER OF SYMBOLS HELD BY C THE SYMBOL TABLE SINCE THE VARIOUS TYPES OF SYMBOLS REQUIRE C DIFFERING AMOUNTS OF STORAGE IN THE TABLE. C C 1) IN THE CASE OF THE MEM VECTOR, THE LENGTH IS DETERMINED C BY THE WDSIZE PARAMETER AND THE LARGEST PROGRAM WHICH YOU C WISH TO COMPILE. THE NUMBER OF 8080 (8-BIT) WORDS WHICH ARE C PACKED INTO EACH MEM ELEMENT IS C C P = WDSIZE/8 C C AND THUS THE LARGEST PROGRAM WHICH CAN BE COMPILED IS C C T = P * N C C WHERE N IS THE DECLARED SIZE OF THE MEM VECTOR. TO CHANGE C THE SIZE OF MEM, ALTER ALL OCCURRENCES OF C C MEM(2500) C C IN EACH SUBROUTINE TO MEM(N), WHERE N REPRESENTS THE NEW C INTEGER CONSTANT SIZE. IN ADDITION, THE 'DATA' STATEMENT C IN BLOCK DATA (LAST PROGRAM SEGMENT) MUST BE CHANGED FOR THE C MACRO PARAMETERS BASED UPON THE CONSTANT VALUE N TO C C DATA WDSIZE /31/, TWO8 /256/, MAXMEM /N/ C C 2) IF THE IMPLEMENTOR WISHES TO INCREASE OR DECREASE THE SIZE C OF THE SYMBOL TABLE, THEN ALL OCCURRENCES OF C C SYMBOL(3000) C C MUST BE CHANGED TO SYMBOL(M), WHERE M IS THE DESIRED INTEGER C CONSTANT SIZE. THE 'DATA' STATEMENTS FOR SYMBOL TABLE PARA- C METERS MUST ALSO BE ALTERED AS SHOWN BELOW. C C DATA SYMAX /M/, SYTOP /0/, SYINFO /M/ C C GOOD LUCK (AGAIN) ... C C F I L E D E F I N I T I O N S C INPUT OUTPUT C C FILE FORTRAN MTS DEFAULT FORTRAN MTS DEFAULT C NUM I/O UNIT I/O UNIT FDNAME I/O UNIT I/O UNIT FDNAME C C 1 1 GUSER *MSOURCE* 11 SERCOM *MSINK* C 2 2 SCARDS *SOURCE* 12 SPRINT *SINK* C 3 3 3 13 13 C 4 4 4 -PLM16## 14 14 C 5 5 5 15 15 C 6 6 6 16 16 C 7 7 7 -PLM17## 17 SPUNCH -LOAD C C C ALL INPUT RECORDS ARE 80 CHARACTERS OR LESS. ALL C OUTPUT RECORDS ARE 120 CHARACTERS OR LESS. C THE FORTRAN UNIT NUMBERS CAN BE CHANGED IN THE C SUBROUTINES GNC AND WRITEL (THESE ARE THE ONLY OC- C CURRENCES OF REFERENCES TO THESE UNITS). C C C C 0 1 2 3 4 5 6 7 8 9 C 0 0 0 0 0 0 0 0 1 1 C 2 3 4 5 6 7 8 9 0 1 C C C $ = . / ( ) + - ' * , < > : ; C 3 3 4 4 4 4 4 4 4 4 4 4 5 5 5 C 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 C C A B C D E F G H I J K L M N O P Q R S T U V W X Y Z C 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 C 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 C C C SEQNO SUB/FUNC NAME C 16280000 SUBROUTINE INITAL C 16560000 INTEGER FUNCTION GET(IP) C 16740000 SUBROUTINE PUT(IP,X) C 16960000 INTEGER FUNCTION ALLOC(I) C 17150000 FUNCTION ICON(I) C 17340000 INTEGER FUNCTION GNC(Q) C 18690000 FUNCTION IMIN(I,J) C 18760000 SUBROUTINE FORM(CC,CHARS,START,FINISH,LENGTH) C 19040000 SUBROUTINE WRITEL(NSPACE) C 19580000 SUBROUTINE CONOUT(CC,K,N,BASE) C 19900000 SUBROUTINE PAD(CC,CHR,I) C 20010000 SUBROUTINE ERROR(I,LEVEL) C 20310000 INTEGER FUNCTION SHR(I,J) C 20350000 INTEGER FUNCTION SHL(I,J) C 20390000 INTEGER FUNCTION RIGHT(I,J) C 20430000 SUBROUTINE DELETE(N) C 20680000 SUBROUTINE APPLY(OP,OP2,COM,CYFLAG) C 23380000 SUBROUTINE GENREG(NP,IA,IB) C 24400000 SUBROUTINE LOADSY C 26100000 SUBROUTINE LOADV(IS,TYPV) C 28330000 SUBROUTINE SETADR(VAL) C 28790000 SUBROUTINE USTACK C 28900000 INTEGER FUNCTION CHAIN(SY,LOC) C 29070000 SUBROUTINE GENSTO(KEEP) C 30880000 SUBROUTINE LITADD(S) C 32120000 SUBROUTINE DUMP(L,U,FA,FE) C 33080000 INTEGER FUNCTION DECODE(CC,I,W) C 34540000 SUBROUTINE EMIT(OPR,OPA,OPB) C 36950000 SUBROUTINE PUNCOD(LB,UB,MODE) C 38010000 SUBROUTINE CVCOND(S) C 38730000 SUBROUTINE SAVER C 40000000 SUBROUTINE RELOC C 41970000 SUBROUTINE LOADIN C 42770000 SUBROUTINE EMITBF(L) C 43510000 SUBROUTINE INLDAT C 44780000 SUBROUTINE UNARY(IVAL) C 45950000 SUBROUTINE EXCH C 46690000 SUBROUTINE STACK(N) C 46790000 SUBROUTINE READCD C 52230000 SUBROUTINE OPERAT(VAL) C 66220000 SUBROUTINE SYDUMP C C GLOBAL VARIABLES INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER TITLE(10),VERS COMMON/TITLES/TITLE,VERS INTEGER TERR(22) LOGICAL ERRFLG COMMON/TERRR/TERR,ERRFLG INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER WDSIZE,WFACT,TWO8,FACT(5) INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS INTEGER MSSG(77) COMMON/MESSG/MSSG INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS C INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER GNC C INITIALIZE MEMORY CALL INITAL C THE FOLLOWING SCANNER COMMANDS ARE DEFINED C ANALYSIS (12) C BPNF (13) C COUNT = I (14) C DELETE = I (15) C EOF (16) C FINISH (17) DUMP CODE AT FINISH C GENERATE (18) C HEADER (19) C INPUT = I (20) C JFILE (CODE)= I (21) C LEFTMARGIN = I (23) C MAP (24) C NUMERIC (EMIT) (25) C OUTPUT = I (26) C PRINT (T OR F) (27) C QUICKDUMP = N (28) HEXADECIMAL DUMP C RIGHTMARG = I (29) C SYMBOLS (30) C TERMINAL (31) (0=BATCH, 1=TERM, 2=INTERLIST) C USYMBOL = I (32) C VARIABLES (33) C WIDTH = I (34) C YPAD = N (36) BLANK PAD ON OUTPUT C ZMARGIN = I (37) SETS LEFT MARGIN FOR I.L. C * = N (47) 0 - COMPILER HANDLES STACK POINTER C 1 - PROGRAMMER HANDLES STACK POINTER C N > 1 (MOD 65536) N IS BASE VALUE OF SP C C CONTRL(1) HOLDS THE ERROR COUNT DO 2 I=1,64 2 CONTRL(I) = -1 CONTRL(1) = 0 CONTRL(12) = 0 CONTRL(13) = 7 CONTRL(14) = 0 CONTRL(15) = 120 CONTRL(16) = 0 CONTRL(17) = 1 CONTRL(18) = 1 CONTRL(19) = 0 CONTRL(20) = 1 CONTRL(21) = 4 CONTRL(23) = 1 CONTRL(24) = 1 CONTRL(25) = 0 CONTRL(26) = 2 CONTRL(27) = 0 CONTRL(28) = 1 CONTRL(29) = 73 CONTRL(30) = 0 CONTRL(31) = 1 CONTRL(32) = 7 CONTRL(33) = 0 CONTRL(34) = 120 CONTRL(36) = 1 CONTRL(37) = 2 CONTRL(47) = 0 C DO 8 I=1,256 ITRAN(I) = 1 8 CONTINUE C DO 5 I=53,64 OTRAN(I) = OTRAN(1) 5 CONTINUE C DO 10 I=1,52 J = OTRAN(I) J = ICON(J) 10 ITRAN(J) = I CALL CONOUT(0,4,8080,10) CALL PAD(1,1,1) CALL FORM(1,TITLE,1,10,10) CALL CONOUT(1,1,VERS/10,10) CALL PAD(1,40,1) CALL CONOUT(1,1,MOD(VERS,10),10) CALL WRITEL(1) I = GNC(0) C CHANGE MARGINS FOR READING INTERMEDIATE LANGUAGE CONTRL(23) = CONTRL(37) CALL WRITEL(0) CODLOC = CONTRL(19) CALL LOADSY CALL READCD IF (ERRFLG) GO TO 10100 C MAKE SURE COMPILER STACK IS EMPTY IF (SP.NE.0) CALL ERROR(144,1) C MAKE SURE EXECUTION STACK IS EMPTY IF (CURDEP(1).NE.0) CALL ERROR(150,1) CALL RELOC C MAY WANT A SYMBOL TABLE FOR THE SIMULATOR CALL WRITEL(0) CALL SYDUMP IF (CONTRL(17).EQ.0) GO TO 90 C DUMP THE PREAMBLE I = OFFSET OFFSET = 0 IF (PREAMB.GT.0) CALL DUMP(0,PREAMB-1,16,1) OFFSET = I C C DUMP THE SYMBOL TABLE BY SEGMENTS UNTIL CODLOC-1 I = OFFSET + PREAMB 15 JP = 99999 JL = 0 C LOCATE NEXT INLINE DATA AT OR ABOVE I JN = 0 NP = INTBAS+1 IF (NP.GT.SYTOP) GO TO 22 DO 20 N=NP,SYTOP L = SYMBOL(N) M = SYMBOL(L-1) IF (M.LT.0) GO TO 20 IF (MOD(M,16).NE.VARB) GO TO 20 J = IABS(SYMBOL(L)) J = MOD(J,65536) IF (J.GT.JP) GO TO 20 IF (J.LT.I) GO TO 20 C CANDIDATE AT J K = MOD(M/16,16) IF (K.GT.2) K = 1 K = K * (M/256) IF (K.EQ.0) GO TO 20 C FOUND ONE AT J WITH LENGTH K BYTES JP = J JN = N JL = K 20 CONTINUE 22 CONTINUE C JP IS BASE ADDRESS OF NEXT DATA STMT, JL IS LENGTH IN BYTES C IF (I.GE.JP) GO TO 30 C CODE IS PRINTED BELOW L = JP-1 IF (L.GT.(CODLOC-1)) L = CODLOC-1 CALL DUMP(I,L,16,1) 30 IF (JP.GE.CODLOC) GO TO 40 C THEN THE DATA SEGMENTS IF (CONTRL(30).EQ.0) GO TO 35 CALL PAD(0,30,1) CALL CONOUT(1,5,JN,10) 35 CALL DUMP(JP,JP+JL-1,16,16) 40 I = JP + JL IF (I.LT.CODLOC) GO TO 15 90 I = CODLOC CALL LOADIN IF (CODLOC.EQ.I) GO TO 100 C DUMP THE INITIALIZED VARIABLES IF (CONTRL(17).NE.0) CALL DUMP(I,CODLOC-1,16,16) 100 IF (CONTRL(13).EQ.0) GO TO 9999 C C PUNCH DECK CALL WRITEL(0) I = CONTRL(26) CONTRL(26) = CONTRL(13) K = OFFSET OFFSET = 0 IF (PREAMB.GT.0) CALL PUNCOD(0,PREAMB-1,1) OFFSET = K J = 2 IF (PREAMB.EQ.0) J = 3 CALL PUNCOD(OFFSET+PREAMB,CODLOC-1,J) CALL PAD(0,1,1) C WRITE A $ CALL PAD(1,38,1) CALL WRITEL(0) CONTRL(26) = I C 9999 CONTINUE C WRITE ERROR COUNT J = CONTRL(26) K = J 10000 CONTINUE CALL WRITEL(0) CONTRL(26) = J I = CONTRL(1) IF (I.EQ.0) CALL FORM(0,MSSG,6,7,77) IF (I.NE.0) CALL CONOUT(2,-5,I,10) CALL PAD(1,1,1) CALL FORM(1,MSSG,8,20,77) IF (I.NE.1) CALL PAD(1,30,1) CALL PAD(0,1,1) CALL WRITEL(0) C CHECK FOR TERMINAL CONTROL OF A BATCH JOB IF ((J.EQ.1).OR.(CONTRL(31).EQ.0)) GO TO 10100 C ARRIVE HERE IF TERMINAL TOGGLE GT 0, AND OUTPUT NOT CONSOLE J = 1 GO TO 10000 10100 CONTINUE STOP END SUBROUTINE INITAL INTEGER WDSIZE,WFACT,TWO8,FACT(5) INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB INTEGER I,J,K WFACT = WDSIZE/8 MAXVM = MAXMEM*WFACT - 1 MEMTOP = MAXVM+1 MEMBOT = -1 C DO 5 I=1,5 FACT(I) = 0 5 CONTINUE C C FACT(WFACT) = 1 J= WFACT-1 DO 10 I=1,J K = WFACT - I FACT(K) = FACT(K+1) * TWO8 10 CONTINUE C DO 15 I=1,MAXMEM MEM(I) = 0 15 CONTINUE RETURN END INTEGER FUNCTION GET(IP) INTEGER I,IP INTEGER WDSIZE,WFACT,TWO8,FACT(5) INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB INTEGER J,K I = IP - OFFSET J = I/WFACT+1 IF (J .GT. MAXMEM) GO TO 9999 J = MEM(J) K = MOD(I,WFACT)+1 GET = MOD(J/FACT(K),TWO8) RETURN 9999 GET = 0 CALL ERROR(101,5) RETURN END SUBROUTINE PUT(IP,X) INTEGER I,IP,X INTEGER WDSIZE,WFACT,TWO8,FACT(5) INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB I = IP - OFFSET J = I/WFACT+1 IF (J .GT. MAXMEM) GO TO 9999 M = MEM(J) K = MOD(I,WFACT)+1 MH = 0 IF (K .EQ. 1) GO TO 10 IFACT = FACT(K-1) MH = (M/IFACT)*IFACT 10 IFACT = FACT(K) M = MOD(M,IFACT) MEM(J) = MH +X*IFACT+M RETURN 9999 CALL ERROR(102,5) RETURN END INTEGER FUNCTION ALLOC(I) INTEGER I INTEGER WDSIZE,WFACT,TWO8,FACT(5) INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB IF (I .LT. 0) GO TO 10 C ALLOCATION IS FROM BOTTOM ALLOC = MEMBOT + OFFSET + 1 MEMBOT = MEMBOT + I IF (MEMBOT .GT. MEMTOP) CALL ERROR(103,5) RETURN C C ALLOCATION IS FROM TOP 10 MEMTOP=MEMTOP + I IF (MEMTOP .LE. MEMBOT) CALL ERROR(104,5) ALLOC = MEMTOP + OFFSET RETURN END FUNCTION ICON(I) INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN C ICON IS CALLED WITH AN INTEGER VARIABLE I WHICH CONTAINS A C CHARACTER READ WITH AN A1 FORMAT. ICON MUST REDUCE THIS CHARACTER C TO A VALUE SOMEWHERE BETWEEN 1 AND 256. NORMALLY, THIS WOULD BE C ACCOMPLISHED BY SHIFTING THE CHARACTER TO THE RIGHTMOST BIT POSI- C TIONS OF THE WORD AND MASKING THE RIGHT 8 BITS. IT IS DONE RATHER C INEFFICIENTLY HERE, HOWEVER, TO GAIN SOME MACHINE INDEPENDENCE. DO 100 K=1,52 J = K IF (I .EQ. OTRAN(K)) GO TO 200 100 CONTINUE J = 1 200 ICON = J RETURN END INTEGER FUNCTION GNC(Q) C GET NEXT CHARACTER FROM THE INPUT STREAM (OR 0 IF C NO CHARACTER IS FOUND) C INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER Q IF (IBP .LE. CONTRL(29)) GO TO 200 C READ ANOTHER RECORD FROM COMMAND STREAM IF (CONTRL(31) .EQ. 0) GO TO 1 IF (CONTRL(20).NE.1) GO TO 1 C INPUT IS FROM TERMINAL, SO GET RID OF LAST LINE CALL PAD(0,1,1) CALL WRITEL(0) 1 IFILE = CONTRL(20) IF (CONTRL(16) .EQ. 1) GO TO 999 10 READ(IFILE,1000) IBUFF 100 DO 110 I=1,80 J = IBUFF(I) J = ICON(J) IBUFF(I) = ITRAN(J) 110 CONTINUE C LP = CONTRL(23) IF (IBUFF(LP).EQ.38) GO TO 300 115 IBP = LP IF (CONTRL(27).EQ.0) GO TO 200 IF (CONTRL(23) .EQ. 1) GO TO 120 CALL FORM(1,IBUFF,1,CONTRL(23)-1,80) CALL PAD(1,1,3) 120 CALL FORM(1,IBUFF,CONTRL(23),CONTRL(29),80) IF(CONTRL(29) .EQ. 80) GO TO 130 CALL PAD(1,1,3) CALL FORM(1,IBUFF,CONTRL(29)+1,80,80) 130 CONTINUE 200 GNC = IBUFF(IBP) IBP = IBP + 1 RETURN 300 CONTINUE IF(IBUFF(2) .EQ. 1) GO TO 115 C SCANNER PARAMETERS FOLLOW LP = LP + 1 305 J = IBUFF(LP) IF (J.EQ.38) GO TO 400 LP = LP + 1 C DO 310 I=LP,80 II = I IF (IBUFF(I) .EQ. 39) GO TO 330 IF (IBUFF(I).EQ.38) GO TO 315 310 CONTINUE C 315 K = CONTRL(J) IF (K .GT. 1) GO TO 320 CONTRL (J) = 1-K GO TO 325 320 CALL ERROR(105,1) 325 IF (II.EQ.80) GO TO 1 LP = II + 1 GO TO 305 330 K = 0 II = II+1 C DO 340 I=II,80 L = IBUFF(I) IF (L .LE. 1) GO TO 340 IF (L .GT. 11) GO TO 350 K = K*10+(L-2) 340 CONTINUE C 350 CONTRL(J) = K C MAY BE MORE $ IN INPUT LINE 360 II = LP + 1 DO 370 I=II,80 LP = I IF (IBUFF(I).EQ.38) GO TO 380 370 CONTINUE C NO MORE $ FOUND GO TO 1 380 LP = LP + 1 GO TO 305 400 CONTINUE C DISPLAY $ PARAMETERS L = 2 K = 64 LP = LP + 1 J = IBUFF(LP) IF (J.EQ.1) GO TO 410 L = J K = J 410 CONTINUE DO 420 I=L,K J = CONTRL(I) IF (J.LT.0) GO TO 420 CALL PAD(0,38,1) CALL PAD(1,I,1) CALL PAD(1,39,1) CALL CONOUT(2,-10,J,10) 420 CONTINUE IF (CONTRL(31).NE.0) CALL PAD(0,1,1) CALL WRITEL(0) GO TO 360 999 GNC = 0 RETURN 1000 FORMAT(80A1) END FUNCTION IMIN(I,J) IF (I .LT. J) GO TO 10 IMIN = J GO TO 20 10 IMIN = I 20 RETURN END SUBROUTINE FORM(CC,CHARS,START,FINISH,LENGTH) C CC = 0 DUMP BUFFER, GO TO NEXT LINE C CC = 1 APPEND TO CURRENT BUFFER C CC = 2 DELETE LEADING BLANKS AND APPEND INTEGER CHARS(LENGTH) INTEGER CC,START,FINISH INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER CONTRL(64) COMMON /CNTRL/CONTRL J = START I = CC + 1 GO TO (100,200,300),I 100 CALL WRITEL(0) 200 IF (J .GT. FINISH) GO TO 999 OBP = OBP + 1 OBUFF(OBP) = CHARS(J) J = J + 1 IF (OBP .GE. CONTRL(34)) GO TO 100 GO TO 200 300 IF (J .GT. FINISH) GO TO 999 IF (CHARS(J) .NE. 1) GO TO 200 J = J + 1 GO TO 300 999 RETURN END SUBROUTINE WRITEL(NSPAC) INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER CONTRL(64),OFILE COMMON /CNTRL/CONTRL NSPACE=NSPAC C NP = CONTRL(36) - 1 IF (OBP.LE.NP) GO TO 998 NBLANK = 1 C DO 5 I=1,OBP J = OBUFF(I) IF (J .NE. 1) NBLANK = I 5 OBUFF(I) = OTRAN(J) C OBP = IMIN(CONTRL(15),NBLANK) OFILE = CONTRL(26) + 10 9 CONTINUE 10 WRITE(OFILE,1000) (OBUFF(I), I=1,OBP) 11 IF(NSPACE.LE.0) GO TO 998 C DO 12 I=1 , OBP 12 OBUFF(I)=OTRAN(1) NSPACE=NSPACE-1 GO TO 9 998 IF (NP.LE.0) GO TO 997 DO 999 I=1,NP 999 OBUFF(I) = 1 997 OBP = NP RETURN 1000 FORMAT (1H ,121A1) 1001 FORMAT(1H ) END SUBROUTINE CONOUT(CC,K,N,BASE) INTEGER CC,K,N,BASE,T(20) LOGICAL ZSUP NP = N ZSUP = K .LT. 0 KP = IMIN (IABS(K),19) C DO 10 I=1,KP 10 T(I) = 1 C IP = KP + 1 C DO 20 I=1,KP LTEMP=IP-I T(LTEMP)=MOD(NP,BASE)+2 NP = NP/BASE IF(ZSUP .AND. (NP .EQ. 0)) GO TO 30 20 CONTINUE C 30 IF(BASE .EQ. 8) GO TO 40 IF(BASE .EQ. 2) GO TO 45 IF(BASE .NE. 16) GO TO 50 KP = KP+1 T(KP) = 19 GO TO 50 40 KP = KP+1 T(KP) = 28 GO TO 50 45 KP = KP+1 T(KP) = 13 50 CALL FORM(CC,T,1,KP,20) RETURN END SUBROUTINE PAD(CC,CHR,I) INTEGER CC,CHR,I INTEGER T(20) J = IMIN(I,20) C DO 10 K=1,J 10 T(K) = CHR C CALL FORM(CC,T,1,J,20) RETURN END SUBROUTINE ERROR(I,LEVEL) C PRINT ERROR MESSAGE - LEVEL IS SEVERITY CODE (TERMINATE AT 5) INTEGER TERR(22) LOGICAL ERRFLG COMMON/TERRR/TERR,ERRFLG INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER MSSG(77) COMMON/MESSG/MSSG CONTRL(1) = CONTRL(1) + 1 CALL PAD(0,42,1) CALL CONOUT(1,5,CONTRL(14),10) CALL PAD(1,43,1) CALL PAD(1,1,2) CALL FORM(1,MSSG,16,20,77) CALL PAD(1,1,1) CALL CONOUT(2,-4,I,10) CALL WRITEL(0) C CHECK FOR SEVERE ERROR - LEVEL GREATER THAN 4 IF (LEVEL.LE.4) GO TO 999 C TERMINATE COMPILATION CALL FORM(0,TERR,1,22,22) CALL WRITEL(0) ERRFLG = .TRUE. 999 RETURN END INTEGER FUNCTION SHR(I,J) SHR = I/(2**J) RETURN END INTEGER FUNCTION SHL(I,J) SHL = I*(2**J) RETURN END INTEGER FUNCTION RIGHT(I,J) RIGHT = MOD(I,2**J) RETURN END SUBROUTINE DELETE(N) INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS C DELETE THE TOP N ELEMENTS FROM THE STACK DO 200 I=1,N IF(SP.GT.0) GO TO 50 CALL ERROR(106,1) GO TO 9999 50 I1 = RASN(SP) I1 = MOD(I1,256) I2 = MOD(I1,16) I1 = I1/16 JP = REGS(1) IF (I1.EQ.0) GO TO 100 IF (JP.EQ.I1) REGS(1) = 0 LOCK(I1) = 0 REGS(I1) = 0 100 IF(I2.EQ.0) GO TO 200 IF (JP.EQ.I2) REGS(1) = 0 LOCK(I2) = 0 REGS(I2) = 0 200 SP = SP - 1 9999 RETURN END SUBROUTINE APPLY(OP,OP2,COM,CYFLAG) INTEGER OP,COM,CYFLAG,OP2 C APPLY OP TO TOP ELEMENTS OF STACK C USE OP2 FOR HIGH ORDER BYTES IF DOUBLE BYTE OPERATION C COM = 1 IF COMMUTATIVE OPERATOR, 0 OTHERWISE C CYFLAG = 1 IF THE CARRY IS INVOLVED IN THE OPERATION INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS C C MAY WANT TO CLEAR THE CARRY FOR THIS OPERATION C C CHECK FOR ONE OF THE OPERANDS IN THE STACK (ONLY ONE CAN BE THERE) C I = SP-1 IP = 0 DO 90 J=I,SP IF ((ST(J).NE.0).OR.(RASN(J).NE.0).OR.(LITV(J).GE.0)) GO TO 90 C C OPERAND IS STACKED CALL GENREG(-2,IA,IB) REGS(IA) = J IF (IP.NE.0) CALL ERROR(152,1) IP = IB IF (PREC(J).GT.1) GO TO 80 C C SINGLE PRECISION RESULT IB = 0 GO TO 85 C C C DOUBLE BYTE OPERAND 80 REGS(IB) = J C 85 RASN(J) = IB*16+IA CALL EMIT(POP,IP,0) CALL USTACK 90 CONTINUE C C MAKE A QUICK CHECK FOR POSSIBLE ACCUMULATOR MATCH C WITH THE SECOND OPERAND IA = RASN(SP) IF (IA.GT.255) CALL CVCOND(SP) IB = RASN(SP-1) IF (IB.GT.255) CALL CVCOND(SP-1) L = REGS(1) IF ((IA*IB*L*COM).EQ.0) GO TO 100 C COMMUTATIVE OPERATOR, ONE MAY BE IN THE ACCUMULATOR IF (L.NE.MOD(IA,16)) GO TO 100 C SECOND OPERAND IN GPR'S, L.O. BYTE IN ACCUMULATOR CALL EXCH C 100 IA = 0 IB = 0 C IS OP1 IN GPR'S C L = RASN(SP-1) IF (L.EQ.0) GO TO 140 C REG ASSIGNED, LOCK REGS CONTAINING VAR I = MOD(L,16) IF (I.EQ.0) GO TO 9990 IA = I LOCK(I) = 1 I = L/16 IF (I.EQ.0) GO TO 110 IB = I LOCK(I) = 1 C C MAY HAVE TO GENERATE ONE FREE REG 110 IF (PREC(SP-1).GE.PREC(SP)) GO TO 120 IB = IA - 1 C C FORCE LOW-ORDER BYTE INTO ACCUMULATOR 120 CONTINUE C CHECK FOR PENDING REGISTER STORE JP = REGS(1) IF (JP.EQ.IA) GO TO 200 IF (JP.NE.0) CALL EMIT(LD,JP,RA) REGS(1) = IA CALL EMIT(LD,RA,IA) GO TO 200 C C IS OP2 IN GPR'S 140 L = RASN(SP) IF (L.EQ.0) GO TO 200 C YES - CAN WE EXCHANGE AND TRY AGAIN C AFTER INSURING THAT A LITERAL HAS NO REGS ASSIGNED LITV(SP) = -1 IF (COM.EQ.0) GO TO 200 150 CALL EXCH GO TO 100 C C OP2 NOT IN GPR'S OR OP IS NOT COMMUTATIVE C CHECK FOR LITERAL VALUE - IS OP2 LITERAL 200 K = LITV(SP) IF (K.LT.0) GO TO 280 C IF ((PREC(SP).GT.1).OR.(PREC(SP-1).GT.1)) GO TO 300 C MAKE SPECIAL CHECK FOR POSSIBLE INCREMENT OR DECREMENT IF (K.NE.1) GO TO 300 C MUST BE ADD OR SUBTRACT WITHOUT CARRY IF ((OP.NE.AD).AND.(OP.NE.SU)) GO TO 300 C FIRST OPERAND MUST BE SINGLE BYTE VARIABLE IF (PREC(SP-1).NE.1) GO TO 300 IF (IA.GT.1) GO TO 230 C OP1 MUST BE IN MEMORY, SO LOAD INTO GPR CALL LOADV(SP-1,0) L = RASN(SP-1) IA = MOD(L,16) IF (IA.EQ.0) GO TO 9990 C ...MAY CHANGE TO INR MEMORY IF STD TO OP1 FOLLOWS... LASTIR = CODLOC 230 JP = IA IF (REGS(RA).EQ.IA) JP = RA IF (OP .EQ. AD) CALL EMIT (IN, JP, 0) IF (OP .EQ. SU) CALL EMIT (DC, JP, 0) GO TO 2000 C C OP1 NOT A LITERAL, CHECK FOR LITERAL OP2 280 IF(LITV(SP-1).LT.0) GO TO 300 IF(COM.EQ.1) GO TO 150 C C GENERATE REGISTERS TO HOLD RESULTS IN LOADV C (LOADV WILL LOAD THE LOW ORDER BYTE INTO THE ACC) 300 CALL LOADV(SP-1,1) L = RASN(SP-1) IA = MOD(L,16) IF (IA.EQ.0) GO TO 9990 LOCK(IA) = 1 IB = L/16 C C IS THIS A SINGLE BYTE / DOUBLE BYTE OPERATION IF ((IB.GT.0).OR.(PREC(SP).EQ.1)) GO TO 400 C GET A SPARE REGISTER IB = IA - 1 IF (IB.EQ.0) GO TO 9990 LOCK(IB) = 1 C C NOW READY TO PERFORM OPERATION C L.O. BYTE IS IN AC, H.O. BYTE IS IN IB. C RESULT GOES TO IA (L.O.) AND IB (H.O.) C C IS OP2 IN GPR'S 400 LP = RASN(SP) K = -1 IF (LP.LE.0) GO TO 500 C C PERFORM ACC-REG OPERATION CALL EMIT(OP,MOD(LP,16),0) GO TO 700 C C IS OP2 A LITERAL 500 K = LITV(SP) IF (K.LT.0) GO TO 600 C C USE CMA IF OP IS XR AND OP2 IS LIT 255 IF (OP.NE.XR.OR.MOD(K,256).NE.255) GO TO 550 CALL EMIT(CMA,0,0) GO TO 700 550 CONTINUE C C PERFORM ACC-IMMEDIATE OPERATION CALL EMIT(OP,-MOD(K,256),0) GO TO 700 C C OP2 IS IN MEMORY - SETUP ADDRESS 600 CONTINUE CALL LOADV(SP,2) C PERFORM OPERATION WITH LOW ORDER BYTE CALL EMIT(OP,ME,0) C C NOW PROCESS HIGH ORDER BYTE 700 CONTINUE C SET UP A PENDING REGISTER STORE C IF THIS IS NOT A COMPARE IF (OP.NE.CP) REGS(1) = IA IF(PREC(SP).EQ.2) GO TO 3000 C SECOND OPERAND IS SINGLE BYTE IF (PREC(SP-1).LT.2) GO TO 2000 C C MAY NOT NEED TO PERFORM OPERATIONS FOR CERTAIN OPERATORS, BUT ... C PERFORM OPERATION WITH H.O. BYTE OF OP1 C OP1 MUST BE IN THE GPR'S - PERFORM DUMMY OPERATION WITH ZERO JP = REGS(1) IF (JP.EQ.0) GO TO 800 IF (JP.EQ.IB) GO TO 850 CALL EMIT(LD,JP,RA) REGS(1)= 0 800 CALL EMIT(LD,RA,IB) 850 CALL EMIT(OP2,0,0) C C MOVE ACCUMULATOR TO GPR 1000 CONTINUE C SET UP PENDING REGISTER STORE REGS(1) = IB C C FIX STACK POINTERS AND VALUES 2000 CONTINUE C SAVE THE PENDING ACCUMULATOR - REGISTER STORE JP = REGS(1) CALL DELETE(2) REGS(1) = JP SP = SP+1 PREC(SP)=1 RASN(SP) = IB*16 + IA LOCK(IA) = 0 ST(SP) = 0 LITV(SP) = -1 REGS(IA) = SP REGV(IA) = -1 IF (IB.LE.0) GO TO 9999 PREC(SP)=2 REGS(IB)=SP LOCK(IB)=0 REGV(IB)=-1 GO TO 9999 C C PREC OF OP2 = 2 3000 CONTINUE C IS H.O. BYTE OF OP2 IN MEMORY IF ((K.GE.0).OR.(LP.GT.0)) GO TO 3100 C POINT TO H.O. BYTE WITH H AND L CALL EMIT(IN,RL,0) REGV(7) = REGV(7) + 1 C C DO WE NEED TO PAD WITH H.O. ZERO FOR OP1 3100 IF (PREC(SP-1).GT.1) GO TO 3200 C IS STORE PENDING JP = REGS(1) IF (JP.EQ.0) GO TO 3150 IF (JP.EQ.IB) GO TO 3250 CALL EMIT(LD,JP,RA) REGS(1) = 0 3150 IF (CYFLAG.EQ.0) CALL EMIT(XR,RA,0) IF (CYFLAG.EQ.1) CALL EMIT(LD,RA,0) GO TO 3250 C C IS H.O. BYTE OF OP2 IN GPR 3200 CONTINUE C IS STORE PENDING JP = REGS(1) IF (JP.EQ.0) GO TO 3220 IF (JP.EQ.IB) GO TO 3250 CALL EMIT(LD,JP,RA) REGS(1) = 0 3220 CALL EMIT(LD,RA,IB) 3250 IF (LP.EQ.0) GO TO 3300 C C OP2 IN GPR'S - PERFORM ACC-REGISTER OPERATION CALL EMIT(OP2,LP/16,0) GO TO 1000 C C OP2 IS NOT IN GPR'S - IS IT A LITERAL 3300 CONTINUE IF (K.LT.0) GO TO 3400 C YES - PERFORM ACC-IMMEDIATE OPERATION C USE CMA IF OP1 IS XR AND OP2 IS 65535 IF (OP2.NE.XR.OR.K.NE.65535) GO TO 3350 CALL EMIT(CMA,0,0) GO TO 1000 3350 CONTINUE CALL EMIT(OP2,-(K/256),0) GO TO 1000 C C PERFORM ACC-MEMORY OPERATION 3400 CALL EMIT(OP2,ME,0) GO TO 1000 C 9990 CALL ERROR(107,5) 9999 RETURN END SUBROUTINE GENREG(NP,IA,IB) INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER C GENERATE N FREE REGISTERS FOR SUBSEQUENT OPERATION N = IABS(NP) C N IS NUMBER OF REGISTERS, NP NEGATIVE IF NO PUSHING ALLOWED 10 IB = 0 IA = 0 IDUMP = 0 C C LOOK FOR FREE RC OR RE AND ALLOCATE IN PAIRS (RC/RB,RE/RD) 100 K = RC IF (REGS(K).EQ.0) GO TO 200 K = RE IF (REGS(K).NE.0) GO TO 9990 200 IA = K IF (N.GT.1) IB = IA - 1 GO TO 9999 C 9990 CONTINUE IF (IDUMP.GT.0) GO TO 9991 IF (NP.LT.0) GO TO 5000 IP = 0 C GENERATE TEMPORARIES IN THE STACK AND RE-TRY C SEARCH FOR LOWEST REGISTER PAIR ASSIGNMENT IN STACK IF (SP.LE.0) GO TO 5000 DO 4000 I=1,SP K = RASN(I) IF (K.EQ.0) GO TO 3950 IF (K.GT.255) GO TO 4000 J = MOD(K,16) IF (LOCK(J).NE.0) GO TO 4000 JP = K/16 IF (JP.EQ.0) GO TO 3900 C OTHERWISE CHECK HO REGISTER IF ((LOCK(JP).NE.0).OR.(JP.NE.(J-1))) GO TO 4000 3900 IF (IP.EQ.0) IP = I GO TO 4000 3950 IF ((ST(I).EQ.0).AND.(LITV(I).LT.0)) IP=0 4000 CONTINUE IF (IP.EQ.0) GO TO 5000 C FOUND ENTRY TO PUSH AT IP J = RASN(IP) JP = J/16 J = MOD(J,16) REGS(J) = 0 IF (JP.GT.0) REGS(JP) = 0 C CHECK PENDING REGISTER STORE K = REGS(1) IF (K.EQ.0) GO TO 4500 IF (K.EQ.J) GO TO 4200 IF (K.NE.JP) GO TO 4500 C STORE INTO HO REGISTER CALL EMIT(LD,JP,RA) GO TO 4400 C PENDING STORE TO LO BYTE 4200 CONTINUE CALL EMIT(LD,J,RA) 4400 REGS(RA) = 0 C C FREE THE REGISTER FOR ALLOCATION C 4500 CALL STACK(1) CALL EMIT(PUSH,J-1,0) C C MARK ELEMENT AS STACKED (ST=0, RASN=0) RASN(IP) = 0 ST(IP) = 0 LITV(IP) = -1 C AND THEN TRY AGAIN GO TO 100 C C TRY FOR MEMORY STORE 5000 CONTINUE IDUMP = 1 CALL SAVER GO TO 100 9991 IA = 0 9999 RETURN END SUBROUTINE LOADSY INTEGER INTPRO(8) COMMON /INTER/INTPRO INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER ATTRIB INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER GNC,RIGHT,SHL,SHR,SIGN C SAVE THE CURRENT INPUT FILE NUMBER M = CONTRL(20) CONTRL(20) = CONTRL(32) 5 I = GNC(0) IF(I.EQ.1) GO TO 5 C LOOK FOR INITIAL '/' IF (I.NE.41) GO TO 8000 C LOAD THE INTERRUPT VECTOR C 10 I = GNC(0) IF (I.EQ.41) GO TO 50 IF ((I.LT.2).OR.(I.GT.9)) GO TO 8000 I = I - 1 C GET THE PROCEDURE NAME CORRESPONDING TO INTERRUPT I-1 J = 0 L = 1 20 K = GNC(0) IF (K.EQ.41) GO TO 30 K = K - 2 IF ((K.LT.0).OR.(K.GT.31)) GO TO 8000 J = J + K*L L = L * 32 GO TO 20 C 30 INTPRO(I) = J IF (CONTRL(30).LT.2) GO TO 10 CALL PAD(0,1,1) CALL PAD(1,20,1) CALL CONOUT(1,1,I-1,10) CALL PAD(1,39,1) CALL PAD(1,30,1) CALL CONOUT(1,5,J,10) CALL WRITEL(0) GO TO 10 C C INTERRUPT PROCEDURES ARE HANDLED. 50 I = GNC(0) IF (I.EQ.1) GO TO 50 C IF (I.NE. 41) GO TO 8000 C C PROCESS NEXT SYMBOL TABLE ENTRY 100 I = GNC(0) IF (I.EQ.41) GO TO 1000 C SYTOP = SYTOP + 1 IF (SYTOP .LT. SYINFO) GO TO 200 CALL ERROR(108,5) SYINFO = SYMAX 200 IF (CONTRL(30).LT.2) GO TO 250 C C WRITE SYMBOL NUMBER AND SYMBOL TABLE ADDRESS CALL PAD(0,1,1) CALL PAD(1,30,1) CALL CONOUT(1,5,SYTOP,10) 250 SYMBOL(SYTOP) = SYINFO SYINFO = SYINFO - 1 ATTRIB = SYINFO C 300 SIGN = 0 IF (I.EQ. 1) SIGN = 1 IF (I.EQ. 45) SIGN = -1 IF (SIGN.EQ.0) GO TO 8000 C L = 1 K = 0 400 I = GNC(0) IF ((I.GE.2).AND.(I.LE.33)) GO TO 600 C C END OF NUMBER IF (SYINFO .GT. SYTOP) GO TO 500 CALL ERROR(109,5) SYINFO = SYMAX 500 IF (CONTRL(30).LT.2) GO TO 550 C C WRITE SYMBOL TABLE ADDRESS AND ENTRY CALL PAD(0,1,4) CALL CONOUT(1,5,SYINFO,10) CALL PAD(1,1,1) KP = 1 IF (SIGN.EQ.-1) KP = 45 CALL PAD(1,KP,1) CALL CONOUT(1,8,K,16) 550 SYMBOL(SYINFO) = SIGN * K SYINFO = SYINFO - 1 C LOOK FOR '/' IF (I.NE.41) GO TO 300 C CHECK FOR SPECIAL CASE AT END OF AN ENTRY ATTRIB = IABS(SYMBOL(ATTRIB)) I = MOD(ATTRIB,16) IF ((I.EQ.PROC).OR.(I.EQ.VARB)) GO TO 545 IF (I.NE.LABEL) GO TO 100 C CHECK FOR SINGLE REFERENCE TO THE LABEL J = ATTRIB/256 IF (J.NE.1) GO TO 100 C ALLOCATE A CELL AND SET TO ZERO C ARRIVE HERE WITH PROC, VARB, OR SINGLE REF LABEL 545 SYMBOL(SYINFO) = 0 SYINFO = SYINFO - 1 IF (I.NE.PROC) GO TO 100 C RESERVE ADDITIONAL CELL FOR STACK DEPTH COUNT I = 0 GO TO 545 C C C GET NEXT DIGIT 600 K = (I-2)*L + K L = L * 32 GO TO 400 1000 CONTINUE C ASSIGN RELATIVE MEMORY ADDRESSES TO VARIABLES IN SYMBOL TABLE I = SYTOP C 65536 = 65280 + 256 LMEM = 65280 1100 IF (I.LE.0) GO TO 9999 C PROCESS NEXT SYMBOL MP = SYMBOL(I) L = -1 K = SYMBOL (MP-1) C K CONTAINS ATTRIBUTES OF VARIABLE IF (K.LT.0) GO TO 1300 IF (RIGHT(K,4).NE. 1) GO TO 1300 C OTHERWISE TYPE IS VARB K = SHR(K,4) L = RIGHT(K,4) K = SHR(K,4) C L IS ELEMENT SIZE, K IS NUMBER OF ELEMENTS IF (L.LE.2) GO TO 1150 C PROBABLY AN INLINE DATA VARIABLE L = -1 GO TO 1300 1150 IF ((MOD(LMEM,2).EQ.1).AND.(L.EQ.2)) LMEM = LMEM - 1 C MEM IS AT THE PROPER BOUNDARY NOW LMEM = LMEM - L*K IF (LMEM.GE.0) GO TO 1200 CALL ERROR(110,1) LMEM = 65280 1200 L = LMEM IF (CONTRL(30).EQ.0) GO TO 1300 IF(I.LE.4.OR.I.EQ.6) GO TO 1300 C WRITE OUT ADDRESS ASSIGNMENT CALL PAD(0,1,1) CALL PAD(1,30,1) CALL CONOUT(1,5,I,10) CALL PAD(1,39,1) CALL CONOUT(1,5,L,10) 1300 SYMBOL(MP) = L I = I - 1 GO TO 1100 C 8000 CALL ERROR(111,1) 9999 CONTINUE C NOW ASSIGN THE LAST ADDRESS TO THE VARIABLE 'MEMORY' C ** NOTE THAT 'MEMORY' MUST BE AT LOCATION 5 IN THE SYMBOL TABLE ** I = SYMBOL(5) SYMBOL(I) = 65280 IF (CONTRL(30).NE.0) CALL WRITEL(0) CONTRL(20) = M RETURN END SUBROUTINE LOADV(IS,TYPV) INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER S,TYP,TYPV C LOAD VALUE TO REGISTER IF NOT A LITERAL C TYP = 1 IF CALL FROM 'APPLY' IN WHICH CASE THE L.O. BYTE IS C LOADED INTO THE ACCUMULATOR INSTEAD OF A GPR. C IF TYP = 2, THE ADDRESS IS LOADED, BUT THE VARIABLE IS NOT. C IF TYP = 3, A DOUBLE BYTE (ADDRESS) FETCH IS FORCED. C IF TYP = 4 THEN DO A QUICK LOAD INTO H AND L C IF TYP = 5, A DOUBLE BYTE QUICK LOAD INTO H AND L IS FORCED INTEGER CONTRL(64) INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS COMMON /CNTRL/CONTRL INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER VARB,INTR,PROC,LABEL,LITER INTEGER CHAIN I = 0 S = IS TYP = TYPV IF (TYP.EQ.2) GO TO 100 C IF (RASN(S).GT.255) CALL CVCOND(S) IF (TYP.EQ.4.OR.TYP.EQ.5) GO TO 3000 IF (RASN(S).GT.0) GO TO 9999 C CHECK FOR PREVIOUSLY STACKED VALUE IF ((ST(S).NE.0).OR.(LITV(S).GE.0)) GO TO 40 CALL GENREG(2,K,I) C CHECK TO ENSURE THE STACK IS IN GOOD SHAPE I = S + 1 10 IF (I.GT.SP) GO TO 30 IF((ST(I).NE.0).OR.(RASN(I).NE.0).OR.(LITV(I).GE.0)) GO TO 20 C FOUND ANOTHER STACKED VALUE CALL ERROR(147,1) 20 I = I + 1 GO TO 10 30 CONTINUE C AVAILABLE CPU REGISTER IS BASED AT K CALL EMIT(POP,K-1,0) REGS(K) = S IF (PREC(SP).LT.2) GO TO 35 REGS(K-1) = S K = (K-1)*16 + K 35 RASN(S) = K C DECREMENT THE STACK COUNT FOR THIS LEVEL CALL USTACK GO TO 9999 C 40 CONTINUE C NO REGISTERS ASSIGNED. ALLOCATE REGISTERS AND LOAD VALUE. I = PREC(S) IF (TYP.NE.3) GO TO 50 C FORCE A DOUBLE BYTE LOAD I = 2 TYP = 0 50 CALL GENREG(I,IA,IB) C IA IS LOW ORDER BYTE, IB IS HIGH ORDER BYTE. IF (IA.LE.0) GO TO 9990 C OTHERWISE REGISTERS HAVE BEEN FOUND. 100 CONTINUE C CHECK FOR LITERAL VALUE (IN ARITH EXP) L = LITV(S) IF ((L.GE.0).AND.(L.LE.65535)) GO TO 2000 C OTHERWISE FETCH FROM MEMORY SP = SP + 1 J = ST(S) CALL SETADR(J) CALL LITADD(SP) C ADDRESS OF VARIABLE IS IN H AND L JP = TYP+1 GO TO (200,300,1000), JP C CALL FROM GENSTO (TYP = 0) 200 CALL EMIT(LD,IA,ME) GO TO 400 C CALL FROM APPLY TO LOAD VALUE OF VARIABLE 300 JP = REGS(1) C CHECK FOR PENDING REGISTER STORE IF (JP.EQ.0) GO TO 350 C HAVE TO STORE ACC INTO REGISTER BEFORE RELOADING CALL EMIT(LD,JP,RA) REGS(1) = 0 350 CALL EMIT(LD,RA,ME) C C CHECK FOR DOUBLE BYTE VARIABLE 400 IF (I.LE.1) GO TO 1000 C LOAD HIGH ORDER BYTE CALL EMIT(IN,RL,0) REGV(7) = REGV(7) + 1 CALL EMIT(LD,IB,ME) C VALUE IS NOW LOADED 1000 CALL DELETE(1) IF (TYP .EQ. 2) GO TO 9999 RASN(S) = IB*16+IA IF (IB.NE.0) REGS(IB) = S REGS(IA) = S IF (IB.NE.0) REGV(IB) = -1 REGV(IA) = - 1 GO TO 9999 C C LOAD A CONSTANT INTO REGISTERS (NON-COM OPERATOR) 2000 CONTINUE LP = MOD(L,256) REGS(IA) = S REGV(IA) = LP IF (TYP.EQ.1) GO TO 2100 C TYP = 0, LOAD DIRECTLY INTO REGISTERS C MAY BE POSSIBLE TO LXI IF (IB.NE.(IA-1)) GO TO 2010 CALL EMIT(LXI,IB,L) GO TO 2210 2010 CALL EMIT(LD,IA,-LP) GO TO 2200 C C TYP = 1, LOAD INTO ACCUMULATOR 2100 CONTINUE C CHECK FOR PENDING REGISTER STORE JP = REGS(1) IF (JP.EQ.0) GO TO 2150 C STORE ACC INTO REGISTER BEFORE CONTINUING CALL EMIT(LD,JP,RA) REGS(1) = 0 2150 IF (LP.EQ.0) CALL EMIT(XR,RA,0) IF (LP.NE.0) CALL EMIT(LD,RA,-LP) C 2200 IF (IB.EQ.0) GO TO 2300 CALL EMIT(LD,IB,-L/256) 2210 REGS(IB) = S REGV(IB) = -L C 2300 RASN(S) = IB*16+IA GO TO 9999 C QUICK LOAD TO H AND L 3000 CONTINUE M = LITV(S) I = RASN(S) K = ST(S) IF (I.NE.0) GO TO 3100 IF (K.NE.0) GO TO 3200 IF (M.GE.0) GO TO 3400 C C VALUE STACKED, SO... CALL USTACK CALL EMIT(POP,RH,0) IF (PREC(S).LT.2) CALL EMIT(LD,RH,0) GO TO 3160 C C REGISTERS ARE ASSIGNED 3100 J = REGS(1) L = MOD(I,16) I = I/16 IF ((J.NE.0).AND.(J.EQ.I)) I = RA IF ((J.NE.0).AND.(J.EQ.L)) L = RA IF ((L.NE.RE).OR.(I.NE.RD)) GO TO 3150 CALL EMIT(XCHG,0,0) GO TO 3160 C NOT IN D AND E, SO USE TWO BYTE MOVE 3150 CALL EMIT(LD,RL,L) C NOTE THAT THE FOLLOWING MAY BE A LHI 0 CALL EMIT(LD,RH,I) 3160 REGV(RH) = -1 REGV(RL) = -1 GO TO 3300 C C VARIABLE , LITERAL OR ADDRESS REFERENCE 3200 IF (K.GT.0) GO TO 3250 C ADR REF - SET H AND L WITH LITADD CALL LITADD(SP) GO TO 3300 C C SIMPLE VARIABLE OR LITERAL REF, MAY USE LHLD C MAY WANT TO CHECK FOR POSSIBLE INX OR DCX, BUT NOW... 3250 IF (M.GE.0) GO TO 3400 M = REGV(RH) L = REGV(RL) IF ((M.EQ.-3).AND.(-L.EQ.K)) GO TO 3260 IF ((M.EQ.-4).AND.(-L.EQ.K)) GO TO 3255 J = CHAIN(K,CODLOC+1) CALL EMIT(LHLD,J,0) GO TO 3260 C 3255 CALL EMIT(DCX,RH,0) 3260 REGV(RH) = -1 REGV(RL) = -1 IF (PREC(S).GT.1.OR.TYP.EQ.5) GO TO 3270 C THIS IS A SINGLE BYTE VALUE CALL EMIT(LD,RH,0) GO TO 3300 C 3270 REGV(RH) = -3 REGV(RL) = -K C 3300 IF (RASN(S).EQ.0) RASN(S) = RH*16+RL GO TO 9999 C C LITERAL VALUE TO H L 3400 CALL EMIT(LXI,RH,M) REGV(RH) = M/256 REGV(RL) = MOD(M,256) GO TO 9999 C 9990 CALL ERROR(112,5) 9999 RETURN END SUBROUTINE SETADR(VAL) INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM C SET TOP OF STACK TO ADDRESS REFERENCE INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER ALTER = 1 C IF (SP .GT. MAXSP) GO TO 9999 C MARK AS ADDRESS REFERENCE ST(SP) = -VAL I = SYMBOL(VAL) J = IABS(SYMBOL(I-1)) PREC(SP) = RIGHT(SHR(J,4),4) I = SYMBOL(I) C *J=SHL(1,16)* J = 65536 IF (I.GE.0) GO TO 4100 J = 0 I = - I 4100 I = RIGHT(I,16) LITV(SP) = J + I RASN(SP) = 0 RETURN 9999 CALL ERROR(113,5) SP = 1 RETURN END SUBROUTINE USTACK C DECREMENT CURDEP AND CHECK FOR UNDERFLOW INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS I = CURDEP(PRSP+1) IF (I.GT.0) GO TO 100 CALL ERROR(148,1) RETURN 100 CURDEP(PRSP+1) = I - 1 RETURN END INTEGER FUNCTION CHAIN(SY,LOC) INTEGER SY,LOC C CHAIN IN DOUBLE-BYTE REFS TO SYMBOL SY, IF NECESSARY INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM I = SYMBOL(SY) J = SYMBOL(I) IF (J.GE.0) GO TO 100 C ABSOLUTE ADDRESS ALREADY ASSIGNED CHAIN = MOD(-J,65536) GO TO 999 C BACKSTUFF REQUIRED 100 I = I - 2 CHAIN = SYMBOL(I) SYMBOL(I) = LOC 999 RETURN END SUBROUTINE GENSTO(KEEP) C KEEP = 0 IF STD, KEEP = 1 IF STO (VALUE RETAINED) INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS INTEGER CHAIN INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS C GENERATE A STORE INTO THE ADDRESS AT STACK TOP C LOAD VALUE IF NOT LITERAL L = LITV(SP-1) IF (L.GE.0) GO TO 100 IQ = 0 CALL LOADV(SP-1,IQ) 100 I1 = RASN(SP-1) I2 = MOD(I1,16) I1 = I1/16 C CHECK FOR PENDING REGISTER STORE JP = REGS(1) IF (JP.EQ.0) GO TO 150 IF (JP.EQ.I1) I1 = 1 IF (JP.EQ.I2) I2 = 1 150 CONTINUE C ** NOTE THAT THIS ASSUMES 'STACKPTR' IS AT 6 IN SYM TAB IF (-ST(SP).EQ.6) GO TO 700 IF (LITV(SP).LT.0) GO TO 1000 C OTHERWISE THIS IS A LITERAL ADDRESS C IF POSSIBLE, GENERATE A SHLD IF (I1.NE.RD.OR.I2.NE.RE.OR.LASTEX.NE.CODLOC-1 1 .OR.PREC(SP).NE.2) GO TO 155 CALL EMIT(XCHG,0,0) I = IABS(ST(SP)) J = CHAIN(I,CODLOC+1) CALL EMIT(SHLD,J,0) REGV(RH) = -3 REGV(RL) = -I IF (KEEP.NE.0) CALL EMIT(XCHG,0,0) GO TO 600 155 CONTINUE CALL LITADD(SP) 160 CONTINUE C WE MAY CHANGE MOV R,M INR R MOV M,R TO INR M. C IF SO, AND THIS IS A NON-DESTRUCTIVE STORE, THE REGISTER C ASSIGNMENT MUST BE RELEASED. IQ = LASTIR C GENERATE LOW ORDER BYTE STORE IF (I2.EQ.0) GO TO 200 CALL EMIT(LD,ME,I2) GO TO 300 C IMMEDIATE STORE 200 CALL EMIT(LD,ME,-(MOD(IABS(L),256))) 300 CONTINUE C C NOW STORE HIGH ORDER BYTE (IF ANY) IF (PREC(SP).EQ.1) GO TO 600 C A DOUBLE BYTE STORE I = 0 C STORE SECOND BYTE CALL EMIT(INCX,RH,0) C REGV(RH) = -3 THEN LHLD HAS OCCURRED ON SYMBOL -REGV(RL) C REGV(RH) = -4 THEN LHLD AND INCX H HAS OCCURRED J = REGV(RH) IF (J.LT.0) GO TO 310 REGV(7) = REGV(7) + 1 GO TO 320 310 REGV(RH) = -4 IF (J.EQ.-3) GO TO 320 C RH AND RL HAVE UNKNOWN VALUES REGV(RH) = -1 REGV(RL) = -1 320 CONTINUE IF (PREC(SP-1).LT.2) GO TO 400 IF (I1.NE.0) GO TO 500 C SECOND BYTE IS LITERAL I = L/256 C ENTER HERE IF LITERAL 400 CONTINUE CALL EMIT(LD,ME,-IABS(I)) GO TO 600 C LD MEMORY FROM REGISTER 500 CALL EMIT(LD,ME,I1) 600 CONTINUE C C NOW RELEASE REGISTER CONTAINING ADDRESS C RELEASE REGISTER ASSIGNMENT FOR VALUE C IF MOV R,M INR R MOV M,R WAS CHANGED TO INR M. IF (IQ.NE.CODLOC) GO TO 650 I = -ST(SP) CALL DELETE(2) SP = SP + 1 ST(SP) = I RASN(SP) = 0 PREC(SP) = 1 LITV(SP) = -1 GO TO 9999 650 CONTINUE CALL DELETE(1) GO TO 9999 C C STORE INTO STACKPTR 700 CONTINUE IF (I2.EQ.0) GO TO 750 CALL EMIT(LD,RL,I2) REGV(RL) = -1 CALL EMIT(LD,RH,I1) REGV(RH) = -1 CALL EMIT (SPHL,0,0) GO TO 600 750 CONTINUE C LOAD SP IMMEDIATE CALL EMIT(LXI,RSP,L) GO TO 600 C C WE HAVE TO LOAD THE ADDRESS BEFORE THE STORE 1000 CONTINUE I = RASN(SP) IF (I.GT.0) GO TO 1100 C REGISTERS NOT ALLOCATED - CHECK FOR STACKED VALUE IF (ST(SP).NE.0) GO TO 1010 C ADDRESS IS STACKED SO POP TO H AND L CALL EMIT(POP,RH,0) CALL USTACK GO TO 1110 1010 CONTINUE C CHECK FOR REF TO SIMPLE BASED VARIABLE I = ST(SP) IF (I.LE.INTBAS) GO TO 1020 C C MAY BE ABLE TO SIMPLIFY (OR ELIMINATE) THE LHLD K = REGV(RH) LP = REGV(RL) IF((K.EQ.-3).AND.(-LP.EQ.I)) GO TO 160 IF((K.EQ.-4).AND.(-LP.EQ.I)) GO TO 1012 J = CHAIN(I,CODLOC+1) CALL EMIT(LHLD,J,0) REGV(RH) = -3 REGV(RL) = -I GO TO 160 1012 CALL EMIT(DCX,RH,0) REGV(RH) = -3 GO TO 160 1020 CONTINUE IF (I2.NE.0) LOCK(I2) = 1 IF (I1.NE.0) LOCK(I1) = 1 C FORCE A DOUBLE BYTE FETCH INTO GPRS CALL LOADV(SP,3) I = RASN(SP) C 1100 JP = REGS(1) J = MOD(I,16) I = I/16 IF ((I2.EQ.0).OR.(I.NE.(J-1))) GO TO 1105 C IF PREVOUS SYLLABLE IS XCHG THEN DO ANOTHER - PEEP WILL FIX IT IF ((I.EQ.RD).AND.(LASTEX.EQ.(CODLOC-1))) GO TO 1107 C USE STAX - SET UP ACCUMULATOR C IF (I2.EQ.1) GO TO 2215 IF (JP.NE.0) CALL EMIT(LD,JP,RA) IF (I1.EQ.1) I1 = JP CALL EMIT(LD,RA,I2) REGS(RA) = 0 2215 CALL EMIT(STAX,I,0) C ***** C IF BYTE DEST WE ARE DONE IF (PREC(SP) .LT. 2) GO TO 1104 C ***** CALL EMIT(INCX,I,0) IF (I1 .NE. 0) GO TO 1102 C ***** C STORE HIGH ORDER ZERO IF((I2 .NE. 1) .OR. (KEEP .NE. 0)) GO TO 1101 CALL EMIT(LD, MOD(RASN(SP-1), 16), RA) 1101 REGS(RA) = 0 CALL EMIT (XR, RA, 0) CALL EMIT (STAX, I, 0) GO TO 1104 C ***** C STORE HIGH ORDER BYTE 1102 IF((I2 .NE. 1) .OR. (KEEP .EQ. 0)) GO TO 1103 CALL EMIT (LD, MOD(RASN(SP-1), 16), RA) REGS(RA) = 0 1103 CONTINUE CALL EMIT (LD, RA, I1) CALL EMIT (STAX, I, 0) C ***** 1104 CALL DELETE (1) GO TO 9999 C ***** C ADDRESS IN GPRS BUT CANNOT USE STAX 1105 CONTINUE IF (J.EQ.JP) J = 1 IF (I.EQ.JP) I=1 IF ((I.EQ.RD).AND.(J.EQ.RE)) GO TO 1107 CALL EMIT(LD,RL,J) CALL EMIT(LD,RH,I) GO TO 1110 1107 CALL EMIT(XCHG,0,0) C XCHG MAY BE REMOVED BY PEEPHOLE OPTIMIZATION 1110 CONTINUE IF (I1.NE.0) LOCK(I1) = 0 IF (I2.NE.0) LOCK(I2) = 0 REGV(6) = -1 REGV(7) = -1 GO TO 160 C 9999 RETURN END SUBROUTINE LITADD(S) INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER S INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS C LOAD H AND L WITH THE ADDRESS OF THE VARIABLE AT S IN C THE STACK IH = LITV(S) IL = MOD(IH,256) IH = IH/256 IR = RH L = IH IF (IH.GE.0) GO TO 10 CALL ERROR(114,1) GO TO 99999 10 CONTINUE C C DEASSIGN REGISTERS I = RASN(S) IF (I.EQ.103) GO TO 99999 C 6*16+7 = 103 JP = REGS(1) DO 50 J=1,2 K = MOD(I,16) I = I/16 IF (K.EQ.0) GO TO 50 IF (K.EQ.JP) REGS(1) = 0 REGS(K) = 0 LOCK(K) = 0 REGV(K) = -1 50 CONTINUE C RASN(S) = 0 C DO 1000 I=6,7 J = REGS(I) IF (J.EQ.0) GO TO 100 K = RASN(J) KP = MOD(K,16) K = K/16 IF (K.EQ.I) K = 0 IF (KP.EQ.I) KP = 0 RASN(J) = K*16+KP C 100 LP = REGV(I) IF (LP.EQ.L) GO TO 700 IF (LP.NE.(L+1)) GO TO 200 CALL EMIT(DC,IR,0) GO TO 700 200 IF(LP.NE.(L-1)) GO TO 300 IF(L.EQ.0) GO TO 300 CALL EMIT(IN,IR,0) GO TO 700 300 IF (I.NE.6) GO TO 350 C NO INC/DEC POSSIBLE, SEE IF L DOES NOT MATCH IF (IL.EQ.REGV(7)) GO TO 350 REGV(7) = IL IF (L.GT.255) GO TO 310 C OTHERWISE THIS IS A REAL ADDRESS CALL EMIT(LXI,RH,IL+IH*256) GO TO 700 310 CONTINUE C THE LXI MUST BE BACKSTUFFED LATER IT = ST(S) IF (IT.GE.0) GO TO 410 IT=-IT IT=SYMBOL(IT) J = SYMBOL(IT-2) C PLACE REFERENCE INTO CHAIN CALL EMIT(LXI,RH,J) SYMBOL(IT-2) = CODLOC-2 GO TO 700 350 IF (L.GT.255) GO TO 400 CALL EMIT(LD,IR,-L) GO TO 700 C THE ADDRESS MUST BE BACKSTUFFED LATER 400 IT = ST(S) IF (IT.LT.0) GO TO 500 410 CALL ERROR(115,1) GO TO 99999 500 IT = IABS(IT) IT = SYMBOL(IT) J = SYMBOL(IT) IF (J.GT.0) GO TO 600 CALL ERROR(116,1) GO TO 99999 C PLACE LINK INTO CODE 600 K = SHR(J,16) SYMBOL(IT) = SHL(CODLOC+1,16)+RIGHT(J,16) KP = MOD(K,256) K = K/256 CALL EMIT(0,K,0) CALL EMIT(0,KP,0) C DONE LOADING ADDRESS ELEMENT 700 CONTINUE C FIX VALUES IN STACK AND REG IF (I.EQ.7) RASN(S) = 103 C 103 = 6*16+7 REGS(I) = S REGV(I) = L L = IL IR = RL 1000 CONTINUE C 99999 RETURN END SUBROUTINE DUMP(L,U,FA,FE) INTEGER L,U,FA,FE,A,B,W,FR,WR,RR INTEGER GET,DECODE,OPCNT LOGICAL SAME INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER DEBASE COMMON /BASE/DEBASE INTEGER ACCLEN,ACCUM(32),TYPE,STYPE,EOFLAG, 1 IDENT,NUMB,SPECL,STR,CONT,VALUE,ASCII(48) COMMON /SCANC/ACCLEN,ACCUM,TYPE,STYPE,EOFLAG, 1 IDENT,NUMB,SPECL,STR,CONT,VALUE,ASCII LP = L W = CONTRL(34) A = 5 B = 3 IF (FA .EQ. 8) A = 6 IF(FE.NE.1) GO TO 10 C SYMBOLIC DUMP B = 6 FR = DEBASE IF (FR.EQ.2) FR = 16 WR = 2 IF(FR.EQ.10) WR = 3 RR = 6-WR IF (FR.NE.10) RR = RR-1 C FR IS FORMAT OF NUMBERS AFTER OP CODES C WR IS THE WIDTH OF THE NUMBER FIELD C RR IS THE NUMBER OF BLANKS AFTER THE NUMBER FIELD GO TO 20 10 IF (FE .EQ. 2) B = 9 IF (FE .EQ. 8) B = 4 20 W = (W - A) / (B + 1) C W IS NUMBER OF ENTRIES ON EACH LINE IF (W .EQ. 0) GO TO 8025 IF (FA .NE. 10) A = A - 1 IF (FE .NE. 10) B = B - 1 C A IS THE WIDTH OF THE ADDRESS FIELD C B IS THE WIDTH OF EACH ENTRY C DO 100 I=1,29 100 ACCUM(I) = 256 NSAME = 0 OPCNT = 0 C 110 SAME = .TRUE. LS = LP I = 0 C 200 IF (LP .GT. U) GO TO 500 I = I + 1 J = GET(LP) LP = LP + 1 J = MOD(J,256) IF (J .NE. ACCUM(I)) SAME = .FALSE. ACCUM(I) = J IF (I .LT. W) GO TO 200 C 300 IF (SAME) GO TO 400 IF (I .EQ. 0) GO TO 9999 CALL CONOUT (0, A, LS, FA) C DO 320 J=1,I CALL PAD(1,1,1) K = ACCUM(J) IF (OPCNT .GT. 0) GO TO 315 IF (FE .NE. 1) GO TO 310 OPCNT = DECODE(1,K,6) GO TO 320 C 315 OPCNT = OPCNT - 1 CALL CONOUT(1,WR,K,FR) CALL PAD(1,1,RR) GO TO 320 310 CALL CONOUT(1,B,K,FE) 320 CONTINUE C IF (LP .LE. U) GO TO 110 GO TO 600 C 400 NSAME = NSAME + 1 IF (NSAME .GT. 1) GO TO 110 CALL PAD(0,1,1) CALL WRITEL(0) GO TO 110 C 500 SAME = .FALSE. GO TO 300 C 600 CALL WRITEL(0) GO TO 9999 8025 CALL ERROR (117, 1) 9999 RETURN END INTEGER FUNCTION DECODE(CC,I,W) C ***************************************** C *INSTRUCTION * DECODING * USING * CTRAN * C ***************************************** C THE ELEMENTS OF CTRAN REPRESENT THE 8080 OPERATION CODES IN A C FORM WHICH IS MORE USABLE FOR INSTRUCTION DECODING IN BOTH THE C DECODE AND INTERP SUBROUTINES. GIVEN AN INSTRUCTION I (BETWEEN 0 C AND 255), CTRAN(I+1) PROVIDES AN ALTERNATE REPRESENTATION OF THE C INSTRUCTION, AS SHOWN BELOW... C 5B 5B 5B OR 5B 3B 2B 5B C ------------------ ----------------------- C / / / / / / / / / C / X / Y / I / / X / Y1 /Y2 / I / C / / / / / / / / / C ------------------ ----------------------- C WHERE FIELD I SPECIFIES A 'CATEGORY' AND THE X AND Y FIELDS C QUALIFY INSTRUCTIONS WITHIN THE CATEGORY. C FIELD I CATEGORY VALUE OF X AND Y FIELDS C ------ ----------------- ---------------------------------------- C 0 MOV THE FIELDS INDICATE THE VALID OPERANDS C INVOLVED... C ACC=0, B = 1, C = 2, D = 3, E = 4, H = 5, C L = 6, M = 7, I = 8, SP= 9 (M IS MEMORY C REFERENCING INSTRUCTION, AND I IS IMMED) C THUS, /3/5/0/ IS A MOV D,H INSTRUCTION. C C 1 INCREMENT, DECRE- THE VALUE OF X DETERMINES THE INSTRUC- C MENT, ARITHMETIC, TION WITHIN THE CATEGORY.. C OR LOGICAL INR = 1, CDR = 2, ADD = 3, ADC = 4, C SUB = 5, SBC = 6, ANA = 7, XRA = 8, C ORA = 9, CMP = 10 C THE VALUE OF Y DETERMINES THE VALID C REGISTER INVOLVED, AS ABOVE. THUS, C /3/4/1/ IS AN ADD E INSTRUCTION. C ------ ----------------- ---------------------------------------- C 2 JUMP, CALL, OR THE VALUE OF X DETERMINES THE EXACT IN- C RETURN STRUCTION.. JUMP=1, CALL=2, RETURN=3 C THE SUBFIELD Y1 DETERMINES THE ORIENTA- C TION OF THE CONDITION.. T=1, F=0 C THE VALUE OF SUBFIELD Y2 GIVES THE CON- C DITION.. CY=0, Z=1, S=2, P=3. C THUS, /3/0/1/2/ IS AN RFZ (RETURN FALSE C ZERO) INSTRUCTION. C ------ - -------------- ---------------------------------------- C 3 MISCELLANEOUS THE VALUE OF THE Y FIELD DETERMINES THE C INSTRUCTION (THE X FIELD GIVES THE VALUE C OF AAA IN THE RST INSTRUCTION) C RLC = 1 RRC = 2 RAL = 3 RAR = 4 C JMP = 5 CALL = 6 RET = 7 RST = 8 C IN = 9 OUT = 10 HLT = 11 STA = 12 C LDA = 13 XCHG = 14 XTHL = 15 SPHL = 16 C PCHL = 17 CMA = 18 STC = 19 CMC = 20 C DAA = 21 SHLD = 22 LHLD = 23 EI = 24 C DI = 25 NOP = 26 27 --- 31 UNDEFINED C (IBYTES GIVES NUMBER OF BYTES FOLLOWING C THE FIRST 23 INSTRUCTIONS OF THIS GROUP) C ------- ---------------- --------------------------------------- C 4 - 11 INSTRUCTIONS RE THE Y FIELD GIVES A REGISTER PAIR NUM- C QUIRING A REGIS BER A = 0, B = 1, D = 3, H = 5, SP = 9 C TER PAIR C THE INSTRUCTIONS IN EACH CATEGORY ARE C DETERMINED BY THE I FIELD.. C LXI = 4 PUSH = 5 POP = 6 C DAD = 7 STAX = 8 LDAX = 9 C INX = 10 DCX = 11 C ------- ---------------- --------------------------------------- C INTEGER CC,I,W,X,Y INTEGER CTRAN(256),INSYM(284),IBYTES(23) COMMON/INST/CTRAN,INSYM,IBYTES INSIZE=284 IP = CTRAN(I+1) X = IP/1024 Y = MOD(IP/32,32) IP = MOD(IP,32)+1 DECODE = 0 C POINT TO THE PROPER CATEGORY C (THE FIRST TWO ARE FOR CONDITION CODES AND REGISTER DESIGNATIONS) J = INSYM(IP+2) C SELECT THE PROPER INSTRUCTION CODE WITHIN THE CATEGORY IF (IP.GT.4) GO TO 500 GO TO (100,200,300,400),IP C MOV 100 K = 1 GO TO 210 C INR ... CMP 200 K = X C MAY BE AN IMMEDIATE OPERATION 210 IF (Y.EQ.8) DECODE = 1 GO TO 1000 C JUMP CALL OR RETURN CONDITIONALLY 300 K = X IF (X.NE.3) DECODE = 2 GO TO 1000 C RLC ... NOP 400 K = Y C CHECK FOR JMP IF (Y.GT.23) GO TO 1000 C RLC ... LDA DECODE = IBYTES(Y) GO TO 1000 C LXI ... DCX 500 K = 1 IF (IP.EQ.5) DECODE = 2 1000 J = J + K L = INSYM(J) J = INSYM(J+1) CALL FORM(CC,INSYM,L,J-1,INSIZE) L = J - L C IF(IP.NE.4) GO TO 1050 C CHECK FOR RST (IF FOUND ADD DECIMAL NUMBER) IF (Y.NE.8) GO TO 1100 C FOUND RST INSTRUCTION CALL PAD(1,1,1) CALL CONOUT(1,1,X,10) L = L + 2 1050 IF (IP.NE.3) GO TO 1100 C CONDITIONAL J = INSYM(2)+1+Y K = INSYM(J) J = INSYM(J+1) CALL FORM(1,INSYM,K,J-1,INSIZE) L = L + J - K 1100 CONTINUE C OPCODE IS WRITTEN. L CHARACTERS ARE IN BUFFER, CHECK FOR MORE IF ((IP.LE.4).AND.(IP.GE.3)) GO TO 1200 C WRITE REGISTER REFERENCE CALL PAD(1,1,1) 1110 M = Y IF (IP.EQ.1) M = X J = INSYM(1) + 1 + M K = INSYM(J) J = INSYM(J+1) CALL FORM(1,INSYM,K,J-1,INSIZE) L = L + J - K + 1 IF (IP.NE.1) GO TO 1200 IP = 0 GO TO 1110 1200 IF (L.GE.W) GO TO 1300 CALL PAD(1,1,W-L) 1300 RETURN END SUBROUTINE EMIT(OPR,OPA,OPB) INTEGER GET,RIGHT INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER REGMAP(9) COMMON/RGMAPP/REGMAP INTEGER OPR,OPA,OPB INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY C C THE FOLLOWING COMMENTS ARE SAMPLE CALLS TO THE EMIT C ROUTINE. NOTE THAT EMIT REQUIRES THREE ARGUMENT AT ALL TIMES C (THE UNUSED ARGUMENTS ARE ZERO). C C CALL EMIT(LD,RA,RB) C CALL EMIT(LD,RC,-34) C CALL EMIT(LD,RD,ME) C CALL EMIT(LD,ME,RE) C CALL EMIT(IN,RH,0) C CALL EMIT(DC,RL,0) C CALL EMIT(AD,RB,0) C CALL EMIT(AD,ME,0) C CALL EMIT(AD,-5,0) C CALL EMIT(SU,RB,0) C CALL EMIT(SB,ME,0) C CALL EMIT(ND,-5,0) C CALL EMIT(XR,0,0) C CALL EMIT(OR,RB,0) C CALL EMIT(CP,RH,0) C CALL EMIT(ROT,ACC,LFT) C CALL EMIT(ROT,CY,LFT) C CALL EMIT(ROT,CY,RGT) C CALL EMIT(JMP,148,0) C CALL EMIT(JMC,TRU*32+ZERO,148) C CALL EMIT(CAL,1048,0) C CALL EMIT(CLC,FAL*32+PARITY,148) C CALL EMIT(RTN,0,0) C CALL EMIT(RTC,FAL*32+CARRY,255) C CALL EMIT(RST,3,0) C CALL EMIT(INP,6,0) C CALL EMIT(OUT,10,0) C CALL EMIT(HALT,0,0) C EMIT A LITERAL BETWEEN 0 AND 255 C CALL EMIT(0,44,0) C C CALL EMIT(STA,300,0) C CALL EMIT(LDA,300,0) C CALL EMIT(XCHG,0,0) C CALL EMIT(SPHL,0,0) C CALL EMIT(PCHL,0,0) C CALL EMIT(CMA,0,0) C CALL EMIT(STC,0,0) C CALL EMIT(CMC,0,0) C CALL EMIT(DAA,0,0) C CALL EMIT(SHLD,300,0) C CALL EMIT(LHLD,300,0) C CALL EMIT(EI,0,0) C CALL EMIT(DI,0,0) C C CALL EMIT(LXI,(RB,RD,RH,RSP),300) C CALL EMIT(PUSH,(RB,RD,RH,RA),0) C CALL EMIT(POP,(RB,RD,RH,RA),0) C CALL EMIT(DAD,(RB,RD,RH,RSP),0) C CALL EMIT(STAX,(RB,RD),0) C CALL EMIT(LDAX,(RB,RD),0) C CALL EMIT(INX,(RB,RD,RH,RSP),0) C CALL EMIT(DCX,(RB,RD,RH,RSP),0) INTEGER BITS(3),ALLOC C N = 1 C IF (CONTRL(25).EQ.0) GO TO 100 C WRITE EMITTER TRACE CALL PAD(0,16,1) CALL PAD(1,42,1) CALL CONOUT(2,-6,OPR,10) CALL PAD(1,48,1) IF (OPA.LT.0) CALL PAD(1,45,1) CALL CONOUT(2,-6,IABS(OPA),10) CALL PAD(1,48,1) IF (OPB.LT.0) CALL PAD(1,45,1) CALL CONOUT(2,-6,IABS(OPB),10) CALL PAD(1,43,1) CALL WRITEL(0) 100 IF (OPR.LE.0) GO TO 9000 BITS(1) = CBITS(OPR) GO TO (1000,1500,1500,2000,2000,2000,2000,2000,2000,2000,2000, 1 3000,4000,5000,4000,5000,10000,5100,7000,8000,8000,10000, 2 9100,9100,9400,9999,9999,9999,9999,9999,9999,9100,9100, 3 9999,9999,9200,9500,9300,9300,9300,9300,9300,9300) 4 ,OPR C 1000 CONTINUE C LOAD OPERATION IF (OPB.GT.0) GO TO 1200 C LRI OPERATION N = 2 BITS(1) = REGMAP(OPA)*8 + 6 BITS(2) = - OPB GO TO 10000 1200 CONTINUE C CHECK FOR POSSIBLE LOAD REGISTER ELIMINATION C IS THIS A LMR OR LRM INSTRUCTION... IF (OPA.NE.ME) GO TO 1210 C MAY CHANGE A MOV R,M INR R MOV M,R TO INR M IF (LASTIR.NE.CODLOC-1) GO TO 1205 I = RIGHT(GET(CODLOC-1),3) + 48 C THE REGISTER LOAD MAY HAVE BEEN ELIMINATED... IF (LASTLD.EQ.CODLOC-2.AND.OPB.EQ.LASTRG) GO TO 1202 CODLOC = CODLOC - 1 MEMBOT = MEMBOT - 1 1202 CONTINUE CALL PUT(CODLOC-1,I) LASTIR = 0 LASTRG = 0 LASTLD = 0 IF (LASTIN.EQ.CODLOC.OR.LASTIN.EQ.CODLOC+1) 1 LASTIN = CODLOC - 1 GO TO 11000 1205 CONTINUE C THIS IS A LOAD MEMORY FROM REGISTER OPERATION - SAVE LASTLD = CODLOC LASTRG = OPB GO TO 1220 1210 IF (OPB.NE.ME) GO TO 1220 C THIS IS A LOAD REGISTER FROM MEMORY - MAYBE ELIMINATE IF (LASTLD.NE.(CODLOC-1)) GO TO 1220 IF (LASTRG.EQ.OPA) GO TO 11000 1220 CONTINUE BITS(1) = BITS(1) + REGMAP(OPA)*8 + REGMAP(OPB) GO TO 10000 C C IN OR DC 1500 CONTINUE BITS(1) = BITS(1) + REGMAP(OPA)*8 GO TO 10000 C 2000 CONTINUE C AD AC SU SB ND XR OR CP IF (OPA.GT.0) GO TO 2200 C IMMEDIATE OPERAND N = 2 BITS(1) = BITS(1) + 70 BITS(2) = - OPA GO TO 10000 C 2200 BITS(1) = BITS(1) + REGMAP(OPA) GO TO 10000 C 3000 CONTINUE C ROT I = (OPA-CY)*2 + (OPB-LFT) BITS(1) = BITS(1) + I*8 GO TO 10000 C C JMP CAL 4000 CONTINUE N = 3 I = OPA 4100 BITS(3) = I/256 BITS(2) = MOD(I,256) GO TO 10000 C C JFC JTC CFC CTC 5000 CONTINUE N = 3 5100 I = MOD(OPA,32) - CARRY I = (I/2)*2 + MOD(I+1,2) J = OPA/32-FAL J = I*2 + J BITS(1) = BITS(1) + J*8 I = OPB GO TO 4100 C C RET HLT C GO TO 10000 C C RST 7000 CONTINUE BITS(1) = BITS(1) + MOD(OPA,8)*8 GO TO 10000 C C INP OUT 8000 CONTINUE N = 2 BITS(2) = OPA GO TO 10000 C C LITERAL VALUE 9000 CONTINUE BITS(1) = OPA GO TO 10000 C STA LDA SHLD LHLD (GET ADDRESS PART) 9100 N = 3 BITS(3) = OPA/256 BITS(2) = MOD(OPA,256) GO TO 10000 C C LXI (GET IMMEDIATE PART) 9200 N = 3 BITS(3) = OPB/256 BITS(2) = MOD(OPB,256) C AND DROP THROUGH... C LXI PUSH POP DAD STAX LDAX INX DCX 9300 I = REGMAP(OPA) C CHECK FOR ACC IF (I.EQ.7) I = 6 9310 CONTINUE BITS(1) = I*8 + BITS(1) GO TO 10000 C XCHG - CHECK FOR PREVIOUS XCHG AND ELIMINATE IF FOUND 9400 CONTINUE IF (LASTEX.NE.(CODLOC-1)) GO TO 9410 MEMBOT = MEMBOT - 1 CODLOC = CODLOC - 1 LASTEX = 0 GO TO 11000 9410 LASTEX = CODLOC GO TO 10000 C PUSH R - CHECK FOR XCHG PUSH D COMBINATION. CHANGE TO PUSH H 9500 IF (LASTEX.NE.(CODLOC-1)) GO TO 9300 IF (OPA.NE.RD) GO TO 9300 MEMBOT = MEMBOT - 1 CODLOC = CODLOC - 1 LASTEX = 0 I = REGMAP(RH) GO TO 9310 C XCHG SPHL PCHL CMA STC CMC DAA EI DI (NO ADDRESS PART) 9999 CONTINUE C 10000 I = ALLOC(N)-1 CODLOC = CODLOC + N DO 10100 J = 1,N 10100 CALL PUT(I+J,BITS(J)) C 11000 CONTINUE RETURN END SUBROUTINE PUNCOD(LB,UB,MODE) C PUNCH CODE FROM LOWER BOUND (LB) TO UPPER BOUND (UB) C MODE = 1 - - PUNCH HEADER ONLY C MODE = 2 - - PUNCH TRAILER ONLY C MODE = 3 - - PUNCH HEADER AND TRAILER INTEGER LB,UB,MODE INTEGER GET,L,U,LP,UP,K,KP,RIGHT,SHR INTEGER IMIN,J,ISUM INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER T(4) INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN C UP = UB LP = LB CALL WRITEL(0) IF (CONTRL(28).NE.0) GO TO 400 T(1) = 25 T(2) = 27 T(3) = 13 T(4) = 17 C DO 10 I=1,4 10 CALL PAD(1,47,20) CALL WRITEL(0) C IF (MOD(LP,8).NE.0) CALL CONOUT(0,-8,LP,10) 100 IF(LP .GT. UP) GO TO 300 IF(MOD(LP,4).NE.0) GO TO 200 IF(MOD(LP,8).NE.0) GO TO 130 IF(MOD(LP,256).NE.0) GO TO 120 C ********* CALL WRITEL(0) DO 110 I=1,4 110 CALL PAD(1,47,20) C 120 CALL CONOUT(0,-8,LP,10) GO TO 200 C 130 CALL PAD(0,1,8) C DECODE A MEMORY LOCATION 200 CALL PAD(1,1,1) CALL FORM(1,T,3,3,4) K=GET(LP) C DO 210 I=1,8 KP = K/(2**(8-I)) KP = MOD(KP,2)+1 210 CALL FORM(1,T,KP,KP,4) C CALL FORM(1,T,4,4,4) LP = LP + 1 GO TO 100 C 300 CALL WRITEL(0) DO 310 I=1,4 310 CALL PAD(1,47,20) CALL WRITEL(0) GO TO 9999 400 CONTINUE C WRITE ******** IF (MOD(MODE,2).EQ.0) GO TO 402 CALL PAD(0,47,20) CALL PAD(1,47,20) 402 CALL WRITEL(0) L = CONTRL(28) IF (L.LT.16) L=16 405 IF (LP.GT.UP) GO TO 500 KP = UP - LP + 1 K = IMIN(KP,L) IF (K.EQ.0) GO TO 500 CALL PAD(1,51,1) CALL CONOUT(1,2,K,16) OBP = OBP - 1 CALL CONOUT(1,4,LP,16) OBP = OBP - 1 ISUM = K + RIGHT(LP,8) + SHR(LP,8) CALL CONOUT(1,2,0,16) OBP = OBP - 1 DO 410 I = 1,K J = GET(LP) ISUM = ISUM + J LP = LP + 1 CALL CONOUT(1,2,J,16) OBP = OBP - 1 410 CONTINUE ISUM = RIGHT(ISUM,8) ISUM = MOD(256-ISUM,256) CALL CONOUT(1,2,ISUM,16) OBP = OBP - 1 CALL WRITEL(0) GO TO 405 500 CONTINUE IF ((MODE/2) .EQ. 0) GO TO 510 C ***** C WRITE END OF FILE RECORD CALL PAD(1,51,1) CALL PAD(1,2,10) C C WRITE ***** AGAIN CALL PAD(0,47,20) CALL PAD(1,47,20) 510 CALL WRITEL(0) 9999 RETURN END SUBROUTINE CVCOND(S) INTEGER S C CONVERT THE CONDITION CODE AT S IN THE STACK TO A BOOLEAN VALUE INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS I = RASN(S) J = I/256 K = MOD(J,16) J = J/16 IA = MOD(I,16) C J = 1 IF TRUE , J = 0 IF FALSE C C K = 1 IF CARRY, 2 IF ZERO, 3 IF SIGN, AND 4 IF PARITY C C WE MAY GENERATE A SHORT SEQUENCE IF (K.GT.2.OR.IA.EQ.0) GO TO 40 IF (REGS(1).NE.IA) GO TO 40 IF (K.EQ.2) GO TO 10 C SHORT CONVERSION FOR TRUE OR FALSE CARRY CALL EMIT(SB,RA,0) IF (J.EQ.0) CALL EMIT(CMA,0,0) GO TO 300 C SHORT CONVERSION FOR TRUE OR FALSE ZERO 10 IF (J.EQ.0) CALL EMIT(AD,-255,0) IF (J.EQ.1) CALL EMIT(SU,-1,0) CALL EMIT(SB,RA,0) GO TO 300 C DO WE HAVE TO ASSIGN A REGISTER 40 IF (IA.NE.0) GO TO 50 CALL GENREG(1,IA,JP) IF (IA.NE.0) GO TO 60 CALL ERROR(118,5) GO TO 9999 60 REGS(IA) = SP I = IA C C CHECK PENDING REGISTER STORE 50 JP = REGS(1) IF (JP.EQ.0) GO TO 100 IF (JP.EQ.IA) GO TO 100 CALL EMIT(LD,JP,RA) REGS(1) = 0 C 100 CONTINUE CALL EMIT(LD,RA,-255) J = (FAL+J)*32 + (CARRY+K-1) CALL EMIT(JMC,J,CODLOC+4) CALL EMIT(XR,RA,0) GO TO 300 C C ACCUMULATOR CONTAINS THE BOOLEAN VALUE (0 OR 1) 300 CONTINUE C SET UP PENDING REGISTER STORE REGS(1) = IA RASN(S) = MOD(I,256) 9999 RETURN END SUBROUTINE SAVER INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM C SAVE THE ACTIVE REGISTERS AND RESET TABLES INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER C FIRST DETERMINE THE STACK ELEMENTS WHICH MUST BE SAVED IC1 = 0 IC2 = 0 I1 = 0 I2 = 0 C IF (SP.EQ.0) GO TO 3000 DO 1000 J=1,SP K = RASN(J) IF (K.GT.255) CALL CVCOND(J) IF (K.LE.0) GO TO 1000 K = RASN(J) IF (K.GE.16) GO TO 800 C SINGLE BYTE IF (LOCK(K).EQ.1) GO TO 1000 ST(J) = I1 IC1 = IC1 + 1 I1 = J GO TO 1000 C C DOUBLE BYTE 800 L = MOD(K,16) K = K/16 IF ((LOCK(L)+LOCK(K)).GT.0) GO TO 1000 ST(J) = I2 I2 = J IC2 = IC2 + 1 1000 CONTINUE C LMEM = LMEM - IC1 - (IC2*2) IF (((MOD(LMEM,2)*IC2).GT.0).AND.(IC1.EQ.0)) LMEM=LMEM-1 C LMEM IS NOW PROPERLY ALIGNED. IF (LMEM.GE.0) GO TO 1100 CALL ERROR(119,1) GO TO 99999 1100 CONTINUE K = LMEM C 2000 IF ((I1+I2).EQ.0) GO TO 3000 IF ((MOD(K,2).EQ.1).OR.(I2.EQ.0)) GO TO 2100 C EVEN BYTE BOUNDARY WITH DOUBLE BYTES TO STORE I = I2 I2 = ST(I) GO TO 2200 C C SINGLE BYTE 2100 I = I1 I1 = ST(I) 2200 IF (I.GT.0) GO TO 2300 CALL ERROR(120,1) GO TO 99999 C C PLACE TEMPORARY INTO SYMBOL TABLE 2300 SYTOP = SYTOP + 1 ST(I) = SYTOP SYMBOL(SYTOP) = SYINFO J = RASN(I) L = 1 IF (J.GE.16) L = 2 SYMBOL(SYINFO) = K K = K + L SYINFO = SYINFO - 1 SYMBOL(SYINFO) = 256 + L*16 + VARB C LENGTH IS 1*256 SYINFO = SYINFO - 1 C LEAVE ROOM FOR LXI CHAIN SYMBOL(SYINFO) = 0 SYINFO = SYINFO - 1 IF (SYTOP.LE.SYINFO) GO TO 2400 CALL ERROR(121,5) GO TO 99999 C 2400 CONTINUE C STORE INTO MEMORY L = RASN(I) RASN (I) = 0 SP = SP + 1 CALL SETADR(SYTOP) CALL LITADD(SP) 2450 I = MOD(L,16) IF (I.NE.REGS(1)) GO TO 2500 I = 1 REGS(RA) = 0 REGV(RA) = -1 2500 CONTINUE CALL EMIT(LD,ME,I) L = L / 16 IF (L.EQ.0) GO TO 2700 C DOUBLE BYTE STORE CALL EMIT(IN,RL,0) REGV(7) = REGV(7) + 1 GO TO 2450 C 2700 CALL DELETE(1) GO TO 2000 C C END OF REGISTER STORES 3000 CONTINUE DO 4000 I=2,7 IF (LOCK(I).EQ.1) GO TO 4000 REGS(I) = 0 REGV(I) = -1 4000 CONTINUE 99999 RETURN END SUBROUTINE RELOC INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB INTEGER INTPRO(8) COMMON /INTER/INTPRO INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER INLOC,OUTLOC,TIMLOC,CASJMP COMMON /BIFLOC/INLOC,OUTLOC,TIMLOC,CASJMP INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS INTEGER RIGHT,SHL,SHR,GET INTEGER SMSSG(29) COMMON/SMESSG/SMSSG INTEGER STSIZE,STLOC C IF (CONTRL(30).LT.2) GO TO 18 DO 12 I=1,SYTOP CALL CONOUT(0,-4,I,10) CALL PAD(1,39,1) CALL CONOUT(1,-6,SYMBOL(I),10) 12 CONTINUE C DO 14 I=SYINFO,SYMAX CALL CONOUT(0,-5,I,10) CALL PAD(1,39,1) J = SYMBOL(I) K = 45 IF (J.GE.0) K = 1 CALL PAD(1,K,1) CALL CONOUT(1,8,IABS(J),16) 14 CONTINUE C 18 CONTINUE C COMPUTE MAX STACK DEPTH REQUIRED FOR CORRECT EXECUTION STSIZE = MAXDEP(1) DO 20 N=1,8 I = INTPRO(N) IF (I.EQ.0) GO TO 20 C GET INTERRUPT PROCEDURE DEPTH I = SYMBOL(I) - 3 I = SYMBOL(I) + 1 C NOTE THAT I EXCEEDS DEPTH BY 1 SINCE RET MAY BE PENDING STSIZE = STSIZE + I 20 CONTINUE STSIZE = STSIZE * 2 C N = STSIZE IF (CONTRL(47).NE.0) N = 0 C ALIGN TO EVEN BOUNDARY, IF NECESSARY IF ((N.NE.0).AND.(MOD(LMEM,2).EQ.1)) LMEM=LMEM-1 STLOC = LMEM LMEM = LMEM - N C STSIZE IS NUMBER OF BYTES REQD FOR STACK, STLOC IS ADDR C IW = CONTRL(34)/14 N = 0 C COMPUTE PAGE TO START VARIABLES I = 0 IF (MOD(CODLOC,256).GT.MOD(LMEM,256)) I = 1 I = I+CODLOC/256 IF (CONTRL(33).GT.I) I = CONTRL(33) C C COMPUTE FIRST RELATIVE ADDRESS PAGE J = LMEM/256 - I IF (J.GE.0) GO TO 50 CALL ERROR(122,1) GO TO 9999 50 DO 300 I=1,SYTOP M = SYMBOL(I) K = SYMBOL(M) IF (K.LT.0) GO TO 300 C C NOW FIX PAGE NUMBER C L = RIGHT(SHR(K,8),8) - J C L IS RELOCATED PAGE NUMBER SYMBOL(M) = SHL(L,8)+RIGHT(K,8) K = SHR(K,16) 100 CONTINUE IF (K.EQ.0) GO TO 150 C BACKSTUFF LHI L INTO LOCATION K-1 IP = GET(K-1)*256+GET(K) CALL PUT(K-1,38) CALL PUT(K,L) K = IP GO TO 100 150 CONTINUE C BACKSTUFF LXI REFERENCES TO THIS VARIABLE K = SYMBOL(M-2) M = SYMBOL(M) C K IS LXI CHAIN HEADER, M IS REAL ADDRESS 160 IF (K.EQ.0) GO TO 300 L = GET(K) + GET(K+1)*256 CALL PUT(K,MOD(M,256)) CALL PUT(K+1,M/256) K = L GO TO 160 300 CONTINUE IF (CONTRL(24).NE.0) CALL WRITEL(0) C C RELOCATE AND BACKSTUFF THE STACK TOP REFERENCES STLOC = STLOC - J*256 310 IF (LXIS.EQ.0) GO TO 320 I = LXIS LXIS = GET(I) + GET(I+1)*256 CALL PUT(I,MOD(STLOC,256)) CALL PUT(I+1,STLOC/256) GO TO 310 320 CONTINUE CALL FORM(0,SMSSG,1,11,29) IF (CONTRL(47).EQ.1) GO TO 330 CALL FORM(1,SMSSG,12,13,29) CALL CONOUT(2,-10,STSIZE,10) CALL FORM(1,SMSSG,24,29,29) GO TO 340 330 CALL FORM(1,SMSSG,14,23,29) 340 CALL WRITEL(0) C C NOW BACKSTUFF ALL OTHER TRC, TRA, AND PRO ADDRESSES C DO 700 I = 1, SYTOP J = SYMBOL(I) K = -SYMBOL(J) L = IABS(SYMBOL(J-1)) L = RIGHT(L,4) IF (L.NE.LABEL.AND.L.NE.PROC) GO TO 700 L = RIGHT(SHR(K,2),14) N = RIGHT(K,2) K = SHR(K,16) 600 IF (L.EQ.0) GO TO 650 M = GET(L) + GET(L+1) * 256 CALL PUT(L,MOD(K,256)) CALL PUT(L+1,K/256) L = M GO TO 600 650 SYMBOL(J) = SHL(K,16) + N 700 CONTINUE IF (PREAMB.LE.0) GO TO 900 DO 710 I=1,8 J = INTPRO(I) IF (J.EQ.0) GO TO 710 J = SYMBOL(J) J = IABS(SYMBOL(J))/65536 INTPRO(I) = J*256 + 195 C INTPRO CONTAINS INVERTED JUMP TO PROCEDURE 710 CONTINUE IF (INTPRO(1).EQ.0) INTPRO(1) = (OFFSET+PREAMB)*256+195 C ** NOTE THAT JUMP INST IS 11000011B = 195D ** K = OFFSET OFFSET = 0 I = 0 J = 1 720 L = INTPRO(J) J = J + 1 730 CALL PUT(I,MOD(L,256)) L = L/256 I = I + 1 IF (I.GE.PREAMB) GO TO 740 IF (MOD(I,8).EQ.0) GO TO 720 GO TO 730 C 740 OFFSET = K 900 CONTINUE 9999 RETURN END SUBROUTINE LOADIN INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER GNC,RIGHT,SHL,SHR,GET C SAVE THE CURRENT INPUT FILE NUMBER M = CONTRL(20) CONTRL(20) = CONTRL(32) C GET RID OF LAST CARD IMAGE IBP = 99999 5 I = GNC(0) IF (I.EQ.1) GO TO 5 IF (I.NE.41) GO TO 8000 C C PROCESS NEXT SYMBOL TABLE ENTRY 100 I = GNC(0) IF (I.EQ.41) GO TO 9999 C I = I - 2 C BUILD ADDRESS OF INITIALIZED SYMBOL K = 32 DO 200 J=1,2 I = (GNC(0)-2)*K+I 200 K = K * 32 C J = SYMBOL(I) K = SYMBOL(J-1) K = MOD(K/16,16) J = SYMBOL(J) C J IS STARTING ADDRESS, AND K IS THE PRECISION OF C THE BASE VARIABLE IF (CODLOC.LE.J) GO TO 300 CALL ERROR(123,1) 300 IF (CODLOC.GE.J) GO TO 350 CALL PUT(CODLOC,0) CODLOC = CODLOC + 1 GO TO 300 C C READ HEX VALUES UNTIL NEXT '/' IS ENCOUNTERED 350 LP = - 1 400 LP = LP + 1 I = GNC(0) - 2 C CHECK FOR ENDING / IF (I.EQ.39) GO TO 100 L = I/16 I = MOD(I,16)*16+(GNC(0)-2) C I IS THE NEXT HEX VALUE, AND L=1 IF BEGINNING OF A NEW BVALUE IF (K.NE.2) GO TO 1000 C DOUBLE BYTE INITIALIZE IF (L.NE.0) GO TO 500 C CHECK FOR LONG CONSTANT IF (LP.LT.2) GO TO 600 500 LP = 0 CALL PUT(CODLOC,I) CALL PUT(CODLOC+1,0) GO TO 1100 C C EXCHANGE PLACES WITH H.O. AND L.O. BYTES 600 N = GET(CODLOC-2) CALL PUT(CODLOC-1,N) CALL PUT(CODLOC-2,I) GO TO 400 C 1000 CALL PUT(CODLOC,I) 1100 CODLOC = CODLOC + K GO TO 400 C C 8000 CALL ERROR(124,1) 9999 CONTINUE CONTRL(20) = M RETURN END SUBROUTINE EMITBF(L) C EMIT CODE FOR THE BUILT-IN FUNCTION L. THE BIFTAB C ARRAY IS HEADED BY A TABLE WHICH EITHER GIVES THE STARTING C LOCATION OF THE BIF CODE IN BIFTAB (IF NEGATIVE) OR THE C ABSOLUTE CODE LOCATION OF THE FUNCTION IF ALREADY C EMITTED. INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER GET,ALLOC INTEGER BIFTAB(41),BIFPAR COMMON /BIFCOD/BIFTAB,BIFPAR I = BIFTAB(L) IF (I.GE.0) GO TO 1000 C CODE NOT YET EMITTED I = -I CALL EMIT(JMP,0,0) C BACKSTUFF ADDRESS LATER BIFTAB(L) = CODLOC C GET NUMBER OF BYTES TO EMIT K = BIFTAB(I) I = I + 1 C THEN THE NUMBER OF RELATIVE ADDRESS STUFFS KP = BIFTAB(I) I = I + 1 C START EMITTING CODE M = I + KP JP = 0 100 IF (JP.GE.K) GO TO 200 IF (MOD(JP,3).NE.0) GO TO 110 N = BIFTAB(M) M = M + 1 110 LP = ALLOC(1) CALL PUT(CODLOC,MOD(N,256)) N = N/256 CODLOC = CODLOC + 1 JP = JP + 1 GO TO 100 C C NOW GO BACK AND REPLACE RELATIVE ADDRESSES WITH C ABSOLUTE ADDRESSES. C 200 JP = 0 N = BIFTAB(L) 300 IF (JP.GE.KP) GO TO 400 M = BIFTAB(I) I = I + 1 K = GET(N+M) + GET(M+N+1)*256 + N CALL PUT(N+M,MOD(K,256)) CALL PUT(N+M+1,K/256) JP = JP + 1 GO TO 300 C 400 CONTINUE I = BIFTAB(L) C BACKSTUFF BRANCH AROUND FUNCTION CALL PUT(I-2,MOD(CODLOC,256)) CALL PUT(I-1,CODLOC/256) C C EMIT CALL ON THE FUNCTION 1000 CALL EMIT(CAL,I,0) RETURN END SUBROUTINE INLDAT INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER POLCHR(18),OPCVAL(51) COMMON /OPCOD/POLCHR,OPCVAL INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER OPR,ADR,VLU,DEF,LIT,LIN, *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR, *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC, *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS, *AX1,AX2,AX3 COMMON /ILCOD/ OPR,ADR,VLU,DEF,LIT,LIN, *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR, *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC, *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS, *AX1,AX2,AX3 C EMIT DATA INLINE IQ = CODLOC L = 0 100 K = 0 IF (LAPOL.EQ.0) GO TO 600 DO 200 J=1,3 150 I = GNC(0) IF (I.EQ.1) GO TO 150 IF ((I.LT.2).OR.(I.GT.33)) GO TO 600 200 K = K *32 + I - 2 C I = K K = LAPOL LAPOL = I C KP = MOD(K,8) K = K / 8 C KP IS TYP AND K IS DATA IF (L.GT.0) GO TO 300 C C DEFINE INLINE DATA SYMBOL IF (KP.NE.DEF) GO TO 600 IC = K IF (K.GT.0) GO TO 400 C INLINE CONSTANT -- SET UP SYMBOL ENTRY SYTOP = SYTOP + 1 IC = - SYTOP SYMBOL(SYTOP) = SYINFO SYINFO = SYINFO - 2 C WILL BE FILLED LATER IF (SYINFO.LT.SYTOP) GO TO 600 GO TO 400 C C READ DATA AND STORE INTO ROM 300 CONTINUE IF (KP.EQ.OPR) GO TO 500 IF (KP.NE.LIT) GO TO 600 CALL EMIT(0,K,0) 400 L = L + 1 GO TO 100 C C END OF DATA 500 CONTINUE IF (K.NE.DAT) GO TO 600 C BACKSTUFF JUMP ADDRESS C NOW FIX SYMBOL TABLE ENTRIES K = IABS(IC) L = L - 1 K = SYMBOL(K) SYMBOL(K) = - IQ K = K - 1 J = SYMBOL(K) C CHECK SYMBOL LENGTH AGAINST COUNT J = J/256 SYMBOL(K) = L*256+16+VARB IF (IC.LT.0) GO TO 550 C CHECK SIZE DECLARED AGAINST SIZE READ IF (J.EQ.L) GO TO 1000 C 600 CONTINUE IF (KP.NE.LIN) GO TO 700 CONTRL(14) = K GO TO 100 700 CALL ERROR(125,1) GO TO 1000 C C THIS IS AN ADDRESS REFERENCE TO A CONSTANT, SO.. 550 SP = SP + 1 ST(SP) = IC RASN(SP) = 0 LITV(SP) = IQ PREC(SP) = 2 C C 1000 CONTINUE 2000 RETURN END SUBROUTINE UNARY(IVAL) INTEGER IVAL,VAL C 'VAL' IS AN INTEGER CORRESPONDING TO THE OPERATIONS-- C RTL(1) RTR(2) SFL(3) SFR(4) SCL(5) SCR(6) HIV(7) LOV(8) INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS C ** NOTE THAT THE FOLLOWING CODE ASSUMES THE VALUE OF RTL = 37 VAL = IVAL - 36 IF (RASN(SP).GT.255) CALL CVCOND(SP) IP = PREC(SP) GO TO (1000,1000,3000,3000,3000,3000,9990,5000,6000),VAL C RTL RTR 1000 CONTINUE IF (IP.GT.1) GO TO 9990 IF (RASN(SP).NE.0) GO TO 1100 CALL LOADV(SP,1) REGS(1) = MOD(RASN(SP),16) 1100 I = MOD(RASN(SP),16) K = REGS(1) IF (K.EQ.0) GO TO 1200 IF (K.EQ.I) GO TO 1300 CALL EMIT(LD,K,RA) 1200 CALL EMIT(LD,RA,I) REGS(1) = I 1300 I = LFT IF (VAL.EQ.2) I = RGT CALL EMIT(ROT,CY,I) GO TO 9999 C C SFL SFR SCL SCR 3000 CONTINUE J = 1 IF (((VAL.EQ.4).OR.(VAL.EQ.6)).AND.(IP.GT.1)) J =0 I = RASN(SP) IF (I.GT.0) GO TO 3100 C C LOAD FROM MEMORY CALL LOADV(SP,J) I = RASN(SP) IF (J.EQ.1) REGS(1) = MOD(I,16) C C MAY HAVE TO STORE THE ACCUMULATOR 3100 IA = MOD(I,16) IB = I/16 K = IA IF (J.NE.1) K = IB JP = REGS(1) C WE WANT REGISTER K TO BE IN THE ACCUMULATOR IF (JP.EQ.K) GO TO 3200 IF (JP.EQ.0) GO TO 3150 CALL EMIT(LD,JP,RA) 3150 CALL EMIT(LD,RA,K) 3200 REGS(1) = K C C SFL AND SFR TAKE SEPARATE PATHS NOW... IF ((VAL.EQ.4).OR.(VAL.EQ.6)) GO TO 4000 C C SFL - CLEAR CARRY AND SHIFT IF (VAL.EQ.3) CALL EMIT(AD,RA,RA) IF (VAL.EQ.5) CALL EMIT(ROT,ACC,LFT) IF (IP.LT.2) GO TO 9999 CALL EMIT(LD,IA,RA) CALL EMIT(LD,RA,IB) CALL EMIT(ROT,ACC,LFT) REGS(1) = IB GO TO 9999 C C SFR - ACCUMULATOR CONTAINS VALUE TO SHIFT FIRST 4000 CONTINUE IF (VAL.EQ.4) CALL EMIT(OR,RA,0) CALL EMIT(ROT,ACC,RGT) IF (IP.LT.2) GO TO 9999 CALL EMIT(LD,IB,RA) CALL EMIT(LD,RA,IA) CALL EMIT(ROT,ACC,RGT) REGS(1) = IA GO TO 9999 C C HIV 5000 CONTINUE IF (IP.LT.2) GO TO 9990 IF (RASN(SP).GT.0) GO TO 5100 CALL LOADV(SP,0) 5100 I = RASN(SP) IP = MOD(I/16, 16) IQ = MOD(I, 16) IF (REGS(1) .EQ. IQ) REGS(1) = 0 REGS(IP) = 0 REGV(IP) = -1 RASN(SP) = IQ PREC(SP) = 1 IF (REGS(1) .NE. IP) GO TO 5200 REGS(1) = IQ GO TO 9999 5200 CALL EMIT (LD, IQ, IP) GO TO 9999 C C LOV 6000 CONTINUE PREC(SP) = 1 C MAY HAVE TO RELEASE REGISTER I = RASN(SP) RASN(SP) = MOD(I,16) I = I/16 IF (I.EQ.0) GO TO 9999 REGS(I) = 0 REGV(I) = -1 IF (REGS(1).EQ.I) REGS(1) = 0 GO TO 9999 C 9990 CALL ERROR(126,1) 9999 RETURN END SUBROUTINE EXCH INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY C EXCHANGE THE TOP TWO ELEMENTS OF THE STACK J = SP-1 IF ((ST(J).NE.0).OR.(RASN(J).NE.0).OR.(LITV(J).GE.0)) GO TO 40 C SECOND ELEMENT IS PUSHED - CHECK TOP ELT IF ((RASN(SP).EQ.0).AND.(LITV(SP).LT.0)) GO TO 30 C TOP ELT IS IN CPU REGS C C ASSUME THERE WILL BE AN IMMEDIATE OPERATION, SO ALLOW C REG/PUSH TO BE CHANGED TO PUSH/REG GO TO 40 C C POP ELEMENT (SECOND IF DROP THRU, TOP IF FROM 30) 20 CALL GENREG(-1,IA,IB) IF (IA.NE.0) GO TO 25 CALL ERROR(107,5) GO TO 40 25 IF (PREC(J).GT.1) IB = IA - 1 CALL EMIT(POP,IA-1,0) CALL USTACK REGS(IA) = J IF (IB.NE.0) REGS(IB) = J RASN(J) = IB*16 + IA IF (J.NE.SP) GO TO 40 J = SP - 1 GO TO 20 C SECOND ELT IS PUSHED, TOP ELT IS NOT IN CPU 30 IF (ST(SP).NE.0) GO TO 40 C BOTH ARE PUSHED, SO GO THRU 20 TWICE J = SP GO TO 20 C 40 J = SP-1 DO 100 I=2,7 IF (REGS(I).NE.SP) GO TO 50 REGS(I) = J GO TO 100 50 IF (REGS(I).EQ.J) REGS(I) = SP 100 CONTINUE I = PREC(SP) PREC(SP) = PREC(J) PREC(J) = I C I = RASN(SP) RASN(SP) = RASN(J) RASN(J) = I C I = ST(SP) ST(SP) = ST(J) ST(J) = I C I = LITV(SP) LITV(SP) = LITV(J) LITV(J) = I C RETURN END SUBROUTINE STACK(N) C ADD N TO CURRENT DEPTH, TEST FOR STACKSIZE EXC MAXDEPTH INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS K = PRSP+1 J = CURDEP(K) + N IF (J.GT.MAXDEP(K)) MAXDEP(K) = J CURDEP(K) = J RETURN END SUBROUTINE READCD INTEGER TERR(22) LOGICAL ERRFLG COMMON/TERRR/TERR,ERRFLG INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR INTEGER XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL COMMON /XFROPT/XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER STHEAD(12) COMMON/STHED/STHEAD INTEGER INTPRO(8) COMMON /INTER/INTPRO INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER POLCHR(18),OPCVAL(51) COMMON /OPCOD/POLCHR,OPCVAL INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER INLOC,OUTLOC,FIRSTI,CASJMP COMMON /BIFLOC/INLOC,OUTLOC,FIRSTI,CASJMP INTEGER OPR,ADR,VLU,DEF,LIT,LIN, *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR, *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC, *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS, *AX1,AX2,AX3 COMMON /ILCOD/ OPR,ADR,VLU,DEF,LIT,LIN, *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR, *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC, *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS, *AX1,AX2,AX3 INTEGER LLOC,LLINE,LCNT INTEGER ALLOC CONTRL(14) = 1 LLINE = 0 LLOC = 0 LCNT = CONTRL(34)/12 ALTER = 0 M = CONTRL(20) CONTRL(20) = CONTRL(21) POLCNT = 0 C RESERVE SPACE FOR INTERRUPT LOCATIONS DO 10 I=1,8 II = 9-I IF (INTPRO(II).NE.0) GO TO 20 10 CONTINUE PREAMB = 0 GO TO 22 20 PREAMB = (II-1)*8+3 C ADJUST CODLOC TO ACCOUNT FOR PREAMBLE 22 IF (CODLOC.LT.PREAMB) CODLOC = PREAMB C ALLOCATE 'PREAMBLE' CELLS AT START OF CODE I = ALLOC(PREAMB) OFFSET = CODLOC - PREAMB C SET STACK POINTER UPON PROGRAM ENTRY J = CONTRL(47) IF (J.EQ.1) GO TO 100 IF (J.NE.0) GO TO 90 C START CHAIN OF LXIS LXIS = CODLOC+1 90 CALL EMIT(LXI,RSP,J) 100 CONTINUE IF (ERRFLG) GO TO 9000 IBASE = 0 C MAY HAVE BEEN STACK OVERFLOW SO... IF (SP.LT.0) SP = 0 IF (CONTRL(12).EQ.0) GO TO 10700 IF ((ALTER.EQ.0).OR.(SP.LE.0)) GO TO 10700 C WRITE STACK CALL PAD(0,1,1) CALL PAD(0,1,2) CALL FORM(1,STHEAD,1,2,12) CALL PAD(1,1,3) CALL FORM(1,STHEAD,3,4,12) CALL PAD(1,1,3) CALL FORM(1,STHEAD,5,8,12) CALL PAD(1,1,2) CALL FORM(1,STHEAD,9,12,12) CALL WRITEL(0) DO 10600 I=1,SP IP = SP - I + 1 K = PREC(IP) CALL CONOUT(0,2,IP,10) CALL CONOUT(1,-2,K,10) CALL PAD(1,1,1) J = ST(IP) IF (J.EQ.0) GO TO 10200 K = 30 IF (J.GE.0) GO TO 10100 K = 12 J = -J 10100 CALL PAD(1,K,1) CALL CONOUT(1,5,J,10) GO TO 10300 C 10200 CALL PAD(1,1,6) 10300 CALL PAD(1,1,1) K = RASN(IP) DO 10400 J=1,2 L = RIGHT(SHR(K,(2-J)*4),4)+11 IF (L.EQ.11) L = 45 CALL PAD(1,1,1) 10400 CALL PAD(1,L,1) C K = LITV(IP) IF (K.LT.0) GO TO 10600 L = 1 IF (SHR(K,16).EQ.0) GO TO 10500 L = 29 K = RIGHT(K,16) 10500 CALL PAD(1,1,1) CALL PAD(1,L,1) CALL CONOUT(1,5,K,10) 10600 CALL WRITEL(0) C WRITE REGISTERS IF (CONTRL(12) .LT. 2) GO TO 10700 DO 10650 I=1,7 IP = REGS(I) KP = LOCK(I) LP = REGV(I) IF ((KP+IP+LP).LT. 0) GO TO 10650 CALL PAD(1,1,1) CALL PAD(1,I+11,1) CALL PAD(1,42,1) K = 32 IF (KP.EQ.1) K=23 CALL PAD(1,K,1) CALL PAD(1,48,1) IF (IP.EQ.0) GO TO 10610 CALL CONOUT(1,2,IP,10) GO TO 10620 10610 CALL PAD(1,47,1) 10620 CALL PAD(1,48,1) IF (LP.LT.0) GO TO 10630 CALL CONOUT(2,-10,LP,16) GO TO 10640 10630 CALL PAD(1,47,1) 10640 CALL PAD(1,43,1) 10650 CONTINUE CALL WRITEL(0) C 10700 K = 0 IF (LAPOL.EQ.0) GO TO 250 DO 200 J=1,3 110 I = GNC(0) IF(I.EQ.1) GO TO 110 IF((I.GE.2) .AND.(I.LE.33)) GO TO 150 CALL ERROR(127,5) GO TO 99999 150 K = K * 32 + (I-2) 200 CONTINUE C C COPY THE ELT JUST READ TO THE POLISH LOOK-AHEAD, AND C INTERPRET THE PREVIOUS ELT C 250 I = K K = LAPOL LAPOL = I C READ AGAIN (ONLY ON FIRST ARRIVAL HERE) IF ELT IS NULL IF (K.LT.0) GO TO 10700 C C CHECK FOR END OF CODE IF (K.EQ.0) GO TO 9000 POLCNT = POLCNT + 1 TYP = RIGHT(K,3) VAL = SHR(K,3) C $G=0 FOR NO TRACE, $G=1 GIVES LINES VS LOCS, C $G=2 YIELDS FULL INTERLIST OF I.L. I = CONTRL(18) IF (I.EQ.0) GO TO 2000 IF (I.GT.1) GO TO 900 C C PRINT LINE NUMBER = CODE LOCATION, IF ALTERED IF ((LLINE.EQ.CONTRL(14)).OR.(LLOC.EQ.CODLOC)) GO TO 2000 C CHANGED COMPLETELY, SO PRINT IT LLINE = CONTRL(14) LLOC = CODLOC I = 1 IF (LCNT.GT.0) GO TO 300 LCNT = CONTRL(34)/12 I = 0 300 LCNT = LCNT - 1 CALL PAD(I,1,1) CALL CONOUT(1,-4,LLINE,10) CALL PAD(1,39,1) CALL CONOUT(1,4,LLOC,16) GO TO 2000 C C OTHERWISE INTERLIST THE I.L. 900 CALL CONOUT(0,5,CODLOC,10) CALL PAD(1,1,1) CALL CONOUT(1,4,CODLOC,16) CALL PAD(1,1,1) CALL CONOUT(1,-5,POLCNT,10) CALL PAD(1,1,1) I = TYP*3+1 CALL FORM(1,POLCHR,I,I+2,18) CALL PAD(1,1,1) I = TYP + 1 J = 1 GO TO (1000,1001,1001,1001,1004,1004),I 1000 J = OPCVAL(VAL+1) DO 400 I=1,3 KP = SHR(J,(3-I)*6) CALL PAD(1,RIGHT(KP,6),1) 400 CONTINUE C GO TO 1100 C 1001 J = 30 1004 CALL PAD(1,J,1) CALL CONOUT(1,5,VAL,10) 1100 CONTINUE CALL WRITEL(0) C 2000 CONTINUE TYP = TYP+1 SP = SP + 1 IF (SP.LE.MAXSP) GO TO 2100 C STACK OVERFLOW CALL ERROR(128,5) SP = 1 2100 PREC(SP) = 0 ST(SP) = 0 RASN(SP) = 0 LITV(SP) = -1 ALTER = 0 GO TO (3000,4000,5000,6000,7000,8000),TYP C OPERATOR 3000 SP = SP - 1 CALL OPERAT(VAL) GO TO 100 C LOAD ADDRESS 4000 CONTINUE IF (SP.LE.1) GO TO 4010 C CHECK FOR ACTIVE CONDITION CODE WHICH MUST BE CHANGED TO BOOLEAN IF (RASN(SP-1).GT.255) CALL CVCOND(SP-1) 4010 I = SYMBOL(VAL) J = SYMBOL(I-1) IF (J.GE.0) GO TO 4500 C LOAD ADDRESS OF BASED VARIABLE. CHANGE TO C LOAD VALUE OF THE BASE, USING THE VARIABLE'S PRECISION IBASE = RIGHT(SHR(-J,4),4) VAL = SYMBOL(I-2) GO TO 5000 4500 CALL SETADR(VAL) GO TO 100 C LOAD VALUE 5000 CONTINUE I = SYMBOL(VAL) J = SYMBOL(I-1) IF (SP.LE.1) GO TO 5010 C ALLOW ONLY A LABEL VARIABLE TO BE STACKED IF(MOD(IABS(J),16).EQ.LABEL) GO TO 5010 C CHECK FOR ACTIVE CONDITION CODE WHICH MUST BE CHANGED TO BOOLEAN IF (RASN(SP-1).GT.255) CALL CVCOND(SP-1) 5010 CONTINUE C CHECK FOR CONDITION CODES IF (VAL.GT.INTBAS) GO TO 5400 IF (VAL.LE.4) GO TO 5100 C MAY BE A CALL TO INPUT OR OUTPUT IF ((VAL.GE.FIRSTI).AND.(VAL.LE.INTBAS)) GO TO 5400 C CHECK FOR REFERENCE TO 'MEMORY' C ** NOTE THAT 'MEMORY' MUST BE AT LOCATION 5 IN THE SYMBOL TABLE ** IF (VAL.EQ.5) GO TO 5400 C ** NOTE THAT 'STACKPTR' MUST BE AT 6 IN SYM TAB IF (VAL.EQ.6) GO TO 5300 CALL ERROR(129,1) GO TO 100 C CARRY ZERO MINUS PARITY C SET TO TRUE/CONDITION (1*16+VAL) 5100 RASN(SP) = (16+VAL)*256 ST(SP) = 0 PREC(SP) = 1 ALTER = 1 GO TO 100 5300 CONTINUE C LOAD VALUE OF STACKPOINTER TO REGISTERS IMMEDIATELY CALL GENREG(2,IA,IB) IF (IB.NE.0) GO TO 5310 CALL ERROR(107,5) GO TO 100 5310 RASN(SP) = IB*16+IA LITV(SP) = -1 ST(SP) = 0 REGS(IA) = SP REGS(IB) = SP PREC(SP) = 2 CALL EMIT(LXI,RH,0) CALL EMIT(DAD,RSP,0) CALL EMIT(LD,IA,RL) CALL EMIT(LD,IB,RH) REGV(RH) = -1 REGV(RL) = -1 ALTER = 1 GO TO 100 5400 IF (J.GE.0) GO TO 5500 C C VALUE REFERENCE TO BASED VARIABLE. FIRST INSURE THAT THIS C IS NOT A LENGTH ATTRIBUTE REFERENCE, (I.E., THE VARIABLE IS C NOT AN ACTUAL PARAMETER FOR A CALL ON LENGTH OR LAST) BY C INSURING THAT THE NEXT POLISH ELT IS NOT AN ADDRESS C REFERENCE TO SYMBOL (LENGTH+1) OR (LAST+1) C NOTE THAT THIS ASSUMES LENGTH AND LAST ARE SYMBOL NUMBERS C 18 AND 19 C IF (LAPOL.EQ.153.OR.LAPOL.EQ.161) GO TO 5500 C LOAD VALUE OF BASE VARIABLE. CHANGE TO LOAD C VALUE OF BASE, FOLLOWED BY A LOD OP. IBASE = RIGHT(SHR(-J,4),4) + 16 VAL = SYMBOL(I-2) I = SYMBOL(VAL) J = SYMBOL(I-1) 5500 ALTER = 1 C EXAMINE ATTRIBUTES ST(SP) = VAL I = RIGHT(J,4) J = SHR(J,4) K = RIGHT(J,4) IF (IBASE.GT.0) K = MOD(IBASE,16) PREC(SP) = K IF (I.LT.(LITER-1)) GO TO 5800 IF ((K.GT.0).AND.(K.LT.3)) GO TO 5900 CALL ERROR(130,1) GO TO 100 5900 LITV(SP) = RIGHT(SHR(J,4),16) 5800 CONTINUE C CHECK FOR BASE ADDRESS WHICH MUST BE LOADED IF (IBASE.LT.16) GO TO 100 C MUST BE A BASED VARIABLE VALUE REFERENCE. C LOAD THE VALUE OF THE BASE AND FOLLOW IT BY C A LOAD OPERATION. K = PREC(SP) C MARK AS A BYTE LOAD FOR THE LOD OPERATION IN OPERAT C LEAVES 2 IF DOUBLE BYTE RESULT AND 6 (=2 MOD 4) IF SINGLE BYTE PREC(SP) = 10 - 4*K CALL OPERAT(LOD) GO TO 100 C C DEFINE LOCATION 6000 CONTINUE C MARK LAST REGISTER LOAD NIL LASTRG = 0 LASTEX = 0 LASTIN = 0 LASTIR = 0 SP = SP - 1 C SAVE REGISTERS IF THIS IS A PROC OR A LABEL WHICH WAS C REFERENCED IN A GO-TO STATEMENT OR WAS COMPILER-GENERATED. IP = SYMBOL(VAL) I = IABS(SYMBOL(IP-1)) C C SAVE THIS DEF SYMBOL NUMBER AND THE LITERAL VALUES OF THE C H AND L REGISTERS FOR POSSIBLE TRA CHAIN STRAIGHTENING. C IF(RIGHT(I,4).NE.LABEL) GO TO 6001 DEFSYM = VAL DEFRH = REGV(RH) DEFRL = REGV(RL) C C WE MAY CONVERT THE SEQUENCE C C TRC L, TRA/PRO/RET, DEF L C C TO AN EQUIVALENT CONDITIONAL TRA/PRO/RET... C 6001 IF (I/256.NE.1) GO TO 6004 IF (TSTLOC.NE.CODLOC) GO TO 6004 IF (CONLOC.NE.XFRLOC-3) GO TO 6004 J = -SYMBOL(IP) K = RIGHT(SHR(J,2),14) IF (K.NE.CONLOC+1) GO TO 6004 C C C ADJUST BACKSTUFFING CHAIN FOR JMP OR CALL C IF (XFRSYM.LE.0) GO TO 6002 K = SYMBOL(XFRSYM) C DECREMENT BACKSTUFF LOCATION BY 3 SYMBOL(K) = SYMBOL(K) + 12 6002 CONTINUE C ARRIVE HERE WITH THE CONFIGURATION TRC...DEF C SYMBOL(IP) = -(SHL(SHR(J,16),16)+RIGHT(J,2)) K = MOD(IABS(SYMBOL(IP-1)),256) IF (SYMBOL(IP-1).LT.0) K = -K SYMBOL(IP-1) = K J = GET(CONLOC) J = GET(CONLOC) J = SHR(J,3) K = MOD(MOD(J,2)+1,2) K = SHL(SHR(J,1),1)+K J = GET(XFRLOC) L = RIGHT(SHR(J,1),2) J = SHL(K,3) + SHL(L,1) 6003 CALL PUT(CONLOC,J) CONLOC = CONLOC + 1 XFRLOC = XFRLOC + 1 J = GET(XFRLOC) IF (XFRLOC.NE.CODLOC) GO TO 6003 CODLOC = CONLOC MEMBOT = MEMBOT - 3 CONLOC = -1 XFRLOC = -1 TSTLOC = -1 C C NOTICE THAT DEFRH AND DEFRL ARE NOW INCORRECT C DEFSYM=0 PREVENTS USE OF THESE VARIABLES... C ... IF A TRA IMMEDIATELY FOLLOWS C DEFSYM = 0 6004 CONTINUE J = RIGHT(I,4) IF (J.NE.LABEL) GO TO 6005 C LABEL FOUND. CHECK FOR REFERENCE TO LABEL I = I/256 IF (I.EQ.0) GO TO 6020 C CHECK FOR SINGLE REFERENCE, NO CONFLICT WITH H AND L IF (I.NE.1) GO TO 6010 I = SYMBOL(IP-2) C CHECK FOR PREVIOUS REFERENCE FORWARD IF (I.EQ.0) GO TO 6010 L = MOD(I,256) I = I/256 J = MOD(I,512) I = I/512 IF (MOD(I,2).NE.1) L = -1 IF (MOD(I/2,2).NE.1) J = -1 C J IS H REG, L IS L REG LOCK(6) = 1 LOCK(7) = 1 CALL SAVER C COMPARE OLD HL WITH NEW HL LOCK(6) = 0 LOCK(7) = 0 K = REGV(6) REGV(6) = -1 IF ((K.EQ.-255).OR.(K.EQ.J)) REGV(6) = J K = REGV(7) REGV(7) = -1 IF ((K.EQ.-255).OR.(K.EQ.L)) REGV(7) = L GO TO 6020 C C OTHERWISE NOT A LABEL, CHECK FOR PROCEDURE ENTRY 6005 CONTINUE IF (J.NE.PROC) GO TO 6010 C SET UP PROCEDURE STACK FOR PROCEDURE ENTRY PRSP = PRSP + 1 IF (PRSP.LE.PRSMAX) GO TO 6008 CALL ERROR(145,5) GO TO 6010 6008 J = IP - 2 PRSTK(PRSP) = J C MARK H AND L AS UNALTERED INITIALLY C / 1B / 1B / 1B / 1B / 9B / 8B / C /H UNAL/L UNAL/H VALD/L VALD/H VALU/L VALU/ C ------------------------------------------- SYMBOL(J) = SHL(3,19) CALL SAVER REGV(6) = -254 REGV(7) = -254 K=CODLOC C SET UP STACK DEPTH COUNTERS MAXDEP(PRSP+1) = 0 CURDEP(PRSP+1) = 0 DO 6009 I=1,8 IF (VAL.NE.INTPRO(I)) GO TO 6009 C INTERRUPT PROCEDURE IS MARKED WITH HO 1 PRSTK(PRSP) = J + 65536 CALL EMIT(PUSH,RH,0) CALL EMIT(PUSH,RD,0) CALL EMIT(PUSH,RB,0) CALL EMIT(PUSH,RA,0) CALL STACK(4) 6009 CONTINUE GO TO 6025 C 6010 CALL SAVER C 6020 CONTINUE C LABEL IS RESOLVED. LAST TWO BITS OF ENTRY MUST BE 01 K=CODLOC 6025 I = -SYMBOL(IP) J = MOD(I,4) I = I/4 IF (J.EQ.1) GO TO 6200 CALL ERROR(131,1) 6200 SYMBOL(IP) = -(SHL(K,16) + SHL(I,2) + 3) C C NOW CHECK FOR PROCEDURE ENTRY POINT C I = SYMBOL(IP-1) IF (RIGHT(I,4).NE.PROC) GO TO 100 I = SHR(I,8) C C BUILD RECEIVING SEQUENCE FOR REGISTER PARAMETERS C IF (I.LT.1) GO TO 100 K = I - 2 IF (K.LT.0) K = 0 IF (I.GT.2) I = 2 DO 6300 J = 1, I SP = SP + 1 IF (SP.LE.MAXSP) GO TO 6310 CALL ERROR(113,5) SP = 1 C (RD,RE) = 69 (RB,RC) = 35 6310 IF (J.EQ.1) L = 35 IF (J.EQ.2) L = 69 RASN(SP) = L ST(SP) = 0 LITV(SP) = -1 PREC(SP) = 2 SP = SP + 1 IF (SP.LE.MAXSP) GOTO 6320 CALL ERROR(113,5) SP = 1 6320 RASN(SP) = 0 LITV(SP) = -1 CALL SETADR(VAL+K+J) CALL OPERAT(STD) 6300 CONTINUE GO TO 100 C LITERAL VALUE 7000 CONTINUE IF (SP.LE.1) GO TO 7010 C CHECK FOR ACTIVE CONDITION CODE WHICH MUST BE CHANGED TO BOOLEAN IF (RASN(SP-1).GT.255) CALL CVCOND(SP-1) 7010 ALTER = 1 LITV(SP) = VAL PREC(SP) = 1 IF (LITV(SP).GT.255) PREC(SP) = 2 GO TO 100 C LINE NUMBER 8000 CONTRL(14) = VAL SP = SP - 1 GO TO 100 9000 CONTINUE CALL EMIT(EI,0,0) CALL EMIT(HALT,0,0) C C MAY BE LINE/LOC'S LEFT IN OUTPUT BUFFER IF (CONTRL(18).NE.0) CALL WRITEL(0) C 99999 CONTRL(20) = M RETURN END SUBROUTINE OPERAT(VAL) INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER CODLOC,ALTER,CBITS(22) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL COMMON /XFROPT/XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL INTEGER GET,SHR,SHL,RIGHT,GNC,POLCNT,TYP,VAL INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /BIFCOD/BIFTAB,BIFPAR INTEGER BIFTAB(41),BIFPAR INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER INLOC,OUTLOC,FIRSTI,CASJMP COMMON /BIFLOC/INLOC,OUTLOC,FIRSTI,CASJMP INTEGER CHAIN C ADD ADC SUB SBC MUL DIV MOD NEG AND IOR C XOR NOT EQL LSS GTR NEQ LEQ GEQ INX TRA C TRC PRO RET STO STD XCH DEL CAT LOD BIF C INC CSE END ENB ENP HAL RTL RTR SFL SFR C HIV LOV CVA ORG AX1 AX2 AX3 ICY = 0 ICOM = 0 IQ = 0 GO TO ( 1 1000, 2000, 3000, 3500, 4000, 5000, 6000,99999, 9000,10000, 2 11000,12000,13000,14000,15000,16000,17000,18000,19000,20000, 3 21000,22000,23000,24000,24000,26000,27000,28000,29000,99999, 4 31000,32000,99999,99999,99999,36000,37000,37000,37000,37000, 5 37000,37000,43000,44000,45000,45100,45200,45500,46000,99999), 6 VAL C C ADD 1000 CONTINUE C MAY DO THE ADD IN H AND L (USING INX OPERATOR) IF (PREC(SP).NE.1) CALL EXCH IF (PREC(SP-1).NE.1) GO TO 1100 CALL EXCH ICY = 1 IOP = AD IOP2 = AC ICOM = 1 GO TO 88888 1100 CONTINUE C SET PREC = 1 FOR INX JP = 1 GO TO 19001 C C ADC 2000 CONTINUE ICY = 1 IOP = AC IOP2 = AC ICOM = 1 GO TO 88888 C C SUB 3000 CONTINUE C CHANGE ADDRESS VALUE - 1 TO ADDRESS VALUE + 65535 AND APPLY ADD IF (PREC(SP-1).EQ.1.OR.LITV(SP).NE.1) GO TO 3100 LITV(SP) = 65535 PREC(SP) = 2 GO TO 1100 3100 CONTINUE ICY = 1 IOP = SU IOP2 = SB GO TO 88888 C C SBC 3500 CONTINUE ICY = 1 IOP = SB IOP2 = SB GO TO 88888 C C MUL 4000 I = 1 J = 2 GO TO 6100 C DIV 5000 I = 2 J = 1 GO TO 6100 C MOD 6000 I = 2 J = 2 6100 CONTINUE C CLEAR CONDITION CODE IF (RASN(SP) .GT. 255) CALL CVCOND(SP) C CLEAR PENDING STORE IF (REGS(RA) .NE. 0) CALL EMIT (LD, REGS(RA), RA) REGS(RA) = 0 C LOCK ANY CORRECTLY ASSIGNED REGISTERS C ....AND STORE THE REMAINING REGISTERS. IF (MOD(RASN(SP),16) .EQ. RE) LOCK(RE) = 1 IF (RASN(SP)/16 .EQ. RD) LOCK(RD) = 1 IF (MOD(RASN(SP-1),16) .EQ. RC) LOCK(RC) = 1 IF (RASN(SP-1)/16 .EQ. RB) LOCK(RB) = 1 CALL SAVER C MARK REGISTER C USED. IF (REGS(RC) .EQ. 0) REGS(RC) = -1 C LOAD TOP OF STACK INTO REGISTERS D AND E. CALL LOADV(SP, 0) IF (PREC(SP) .EQ. 1) CALL EMIT (LD, RD, 0) C NOW DEASSIGN REGISTER C UNLESS CORRECTLY LOADED. IF (REGS(RC) .EQ. -1) REGS(RC) = 0 C LOAD T.O.S. - 1 INTO REGISTERS B AND C. CALL LOADV(SP-1, 0) IF (PREC(SP-1) .EQ. 1) CALL EMIT(LD, RB, 0) CALL DELETE(2) C C CALL THE BUILT-IN FUNCTION CALL EMITBF(I) C REQUIRES 2 LEVELS IN STACK FOR BIF (CALL AND TEMP.) CALL STACK(2) CALL USTACK CALL USTACK C AND THEN RETRIEVE RESULTS DO 6500 K=1,7 6500 LOCK(K) = 0 C CANNOT PREDICT WHERE REGISTERS H AND L WILL END UP REGV(RL) = -1 REGV(RH)=-1 SP = SP + 1 ST(SP) = 0 PREC(SP) = 2 LITV(SP) = -1 IF (J.EQ.2) GO TO 6600 RASN(SP) = RB*16 + RC REGS(RB)=SP REGS(RC)=SP GO TO 99991 6600 RASN(SP) = RD*16 + RE REGS(RD)=SP REGS(RE)=SP GO TO 99991 C C AND 9000 CONTINUE IOP = ND 9100 ICOM = 1 GO TO 88887 C C IOR 10000 CONTINUE IOP = OR GO TO 9100 C C XOR 11000 CONTINUE IOP = XR GO TO 9100 C C NEGATE (COMPLEMENT THE ENTIRE NUMBER) 12000 CONTINUE I = RASN(SP) IF (I.LE.255) GO TO 12100 C C CONDITION CODE - CHANGE PARITY J = 1 - (I/4096) RASN(SP) = J*4096 + MOD(I,4096) GO TO 99991 C 12100 CONTINUE C PERFORM XOR WITH 255 OR 65535 (BYTE OR ADDRESS) I = PREC(SP) J = 256**I SP = SP + 1 LITV(SP) = J - 1 PREC(SP) = I GO TO 11000 C 13000 CONTINUE C EQUAL TEST IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13200 C C MARK AS TRUE/ZERO (1*16+2) J = 18 13050 ICOM = 1 13080 IOP = SU 13090 IOP2 = 0 13100 CALL APPLY(IOP,IOP2,ICOM,ICY) C MARK AS CONDITION CODE RASN(SP) = J*256 + RASN(SP) GO TO 99991 C C DOUBLE BYTE EQUAL 13200 CONTINUE IQ = 1 C MARK AS TRUE/ZERO (1*16 + 2) J = 18 13300 ICOM = 1 13400 IOP = SU IOP2 = SB ICY = 1 CALL APPLY(IOP,IOP2,ICOM,ICY) C CHANGE TO CONDITION CODE I = RASN(SP) IP = MOD(I,16) IF (IQ.EQ.1) CALL EMIT(OR,IP,0) C C GET RID OF HIGH ORDER REGISTER IN THE RESULT REGS(1) = IP RASN(SP) = J*256 + IP PREC(SP) = 1 LITV(SP) = -1 ST(SP) = 0 J = MOD(I/16,16) IF (J.EQ.0) GO TO 99991 LOCK(J) = 0 REGS(J) = 0 REGV(J) = - 1 GO TO 99991 C 14000 CONTINUE C LSS - SET TO TRUE/CARRY (1*16+1) J = 17 IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13400 14010 IF (LITV(SP).NE.1) GO TO 13080 IOP = CP GO TO 13090 C 15000 CONTINUE C GTR - CHANGE TO LSS CALL EXCH GO TO 14000 C 16000 CONTINUE C NEQ C MARK AS FALSE/ZERO (0*16+2) J = 2 IQ = 1 IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13300 GO TO 13050 C 17000 CONTINUE C LEQ - CHANGE TO GEQ CALL EXCH C 18000 CONTINUE C GEQ - SET TO FALSE/CARRY (0*16+1) J = 1 IF ((PREC(SP)+PREC(SP-1)).GT.2) GO TO 13400 GO TO 14010 C C INX 19000 CONTINUE JP = PREC(SP-1) C INX IS ALSO USED FOR ADDING ADDRESS VALUES, ENTERING FROM ADD 19001 CONTINUE C BASE MAY BE INDEXED BY ZERO... IF (LITV(SP).NE.0) GO TO 19002 C JUST DELETE THE INDEX AND IGNORE THE INX OPERATOR CALL DELETE(1) GO TO 99991 19002 CONTINUE IF (RASN(SP).GT.255) CALL CVCOND(SP) J = REGS(1) IH = RASN(SP) IL = MOD(IH,16) IH = IH/16 JH = RASN(SP-1) JL = MOD(JH,16) JH = JH/16 C CHECK FOR PENDING STORE TO BASE OR INDEX IF ((J.EQ.0).OR.((J.NE.JH).AND.(J.NE.JL) 1 .AND.(J.NE.IH).AND.(J.NE.IL))) GO TO 19010 CALL EMIT(LD,J,RA) REGS(1) = 0 19010 CONTINUE C MAKE SURE THAT D AND E ARE AVAILABLE IF ((REGS(RE).EQ.0).AND.(REGS(RD).EQ.0)) GO TO 19020 IF ((IL.EQ.RE).OR.(JL.EQ.RE)) GO TO 19020 C MARK ALL REGISTERS FREE IF (IL.NE.0) REGS(IL) = 0 IF (JL.NE.0) REGS(JL) = 0 CALL GENREG(2,IA,IB) REGS(IA) = 1 CALL GENREG(2,IC,IB) REGS(IA) = 0 C ALL REGS ARE CLEARED EXCEPT BASE AND INDEX, IF ALLOCATED. IF (IL.NE.0) REGS(IL) = SP IF (JL.NE.0) REGS(JL) = SP-1 C GET INDEX FROM MEMORY, IF NECESSARY 19020 CONTINUE C IF LITERAL 1 OR -1, USE INX OR DCX IF (LITV(SP).EQ.1.OR.LITV(SP).EQ.65535) GO TO 19040 C IF THE INDEX IS CONSTANT, AND THE BASE AN ADDRESS VARIABLE, C DOUBLE THE LITERAL VALUE AT COMPILE TIME IF (LITV(SP).LT.0.OR.JP.EQ.1) GO TO 19030 LITV(SP) = LITV(SP) + LITV(SP) JP = 1 19030 CONTINUE I = 0 IF (LITV(SP).GE.0) I = 3 CALL LOADV(SP,I) 19040 CONTINUE C IF THE INDEX WAS ALREADY IN THE REGISTERS, MAY C HAVE TO EXTEND PRECISION TO ADDRESS. IH = RASN(SP) IL = MOD(IH,16) IH = IH/16 IF (IL.EQ.0.OR.IH.NE.0) GO TO 19050 IH = IL-1 CALL EMIT (LD,IH,0) 19050 CONTINUE I = DAD IF (LITV(SP).EQ.1) I = INCX IF (LITV(SP).EQ.65535) I = DCX IF (IH.EQ.0) IH = RH C DELETE THE INDEX. (NOTE THAT SP WILL THEN POINT TO THE BASE) CALL DELETE(1) C LOAD THE BASE INTO THE H AND L REGISTERS CALL LOADV(SP,5) C ADD THE BASE AND INDEX CALL EMIT(I,IH,0) C AND ADD INDEX AGAIN IF BASE IS AN ADDRESS VARIABLE. IF (JP.NE.1) CALL EMIT(I,IH,0) CALL EMIT(XCHG,0,0) C NOTE XCHG HERE AND REMOVE WITH PEEPHOLE OPTIMIZATION LATER C I = PREC(SP) CALL DELETE(1) SP = SP + 1 ST(SP) = 0 PREC(SP) = I LITV(SP) = -1 REGV(RH) = -1 REGV(RL) = -1 RASN(SP) = RD*16 + RE REGS(RD) = SP REGS(RE) = SP GO TO 99991 C C TRA - CHECK STACK FOR SIMPLE LABEL VARIABLE 20000 IOP = 1 C IN CASE THERE ARE ANY PENDING VALUES ... LOCK(6) = 1 LOCK(7) = 1 CALL SAVER LOCK(6) = 0 LOCK(7) = 0 C THIS MAY BE A JUMP TO AN ABSOLUTE ADDRESS M = LITV(SP) IF (M .LT. 0) GO TO 20050 C ABSOLUTE JUMP - PROBABLY TO ASSEMBLY LANGUAGE SUBRTNE... C ...SO MAKE H AND L REGISTERS UNKNOWN REGV(RH) = -1 REGV(RL) = -1 CALL EMIT (JMP, M, 0) CALL DELETE (1) GO TO 99991 20050 I = ST(SP) IF (I.GT.0) GO TO 20100 IF ((IOP.EQ.1).AND.(I.EQ.0)) GO TO 20700 C COULD BE A COMPUTED ADDRESS CALL ERROR(134,1) GO TO 99990 20100 I = SYMBOL(I) J = SYMBOL(I-1) J = RIGHT(J,4) C MAY BE A SIMPLE VARIABLE IF ((IOP.EQ.1).AND.(J.EQ.VARB)) GO TO 20700 IF (((IOP.EQ.3).AND.(J.EQ.PROC)).OR.(J.EQ.LABEL)) GO TO 20200 CALL ERROR(135,1) GO TO 99990 20200 J = - SYMBOL(I) M = SHR(J,16) IF (IOP.NE.1) GO TO 20206 IT = IABS(SYMBOL(I-1)) IT = RIGHT(SHR(IT,4),4) C IT IS TYPE OF LABEL... C 3 IS USER-DEFINED OUTER BLOCK, 4 IS USER DEFINED C NOT OUTER BLOCK, 5 IS COMPILER DEFINED IF (IT.NE.5) GO TO 20206 C C THIS TRA IS ONE OF A CHAIN OF COMPILER GENERATED C TRA'S - STRAIGHTEN THE CHAIN IF NO CODE HAS BEEN C GENERATED SINCE THE PREVIOUS DEF. C IF (DEFSYM.LE.0) GO TO 20206 K = SYMBOL(DEFSYM) IF(RIGHT(SHR(SYMBOL(K-1),4),4).NE.5) GO TO 20206 L = -SYMBOL(K) JP = SHR(L,16) IF (JP.NE.CODLOC) GO TO 20205 C C ADJUST THE REFERENCE COUNTS AND OPTIMIZATION C INFORMATION FOR BOTH DEF'S. C IA = SHR(IABS(SYMBOL(K-1)),8) IB = 0 IF (IA.EQ.1) IB = SYMBOL(K-2) IF (DEFRH.EQ.-255) IA = IA - 1 SYMBOL(K-1) = 84 C I.E., ZERO REFERENCES TO COMPILER GENERATED LABEL IF (SHR(IABS(SYMBOL(I-1)),8).EQ.1) SYMBOL(I-2) = IB SYMBOL(I-1) = SYMBOL(I-1) + IA * 256 C CORRECTED REFERENCE COUNT FOR OBJECT OF THE DEF C C MERGE THE BACKSTUFFING CHAINS C 20201 IA = RIGHT(SHR(L,2),14) IF (IA.EQ.0) GO TO 20203 IB = GET(IA) + GET(IA+1) * 256 L = SHL(JP,16) + SHL(IB,2) + RIGHT(L,2) SYMBOL(K) = -L IP = RIGHT(SHR(J,2),14) CALL PUT(IA,MOD(IP,256)) CALL PUT(IA+1,IP/256) J = SHL(M,16) + SHL(IA,2) + RIGHT(J,2) SYMBOL(I) = -J GO TO 20201 20203 CONTINUE C C EQUATE THE DEFS C DO 20202 IA = 1,SYTOP IF (SYMBOL(IA) .EQ. K) SYMBOL(IA) = I 20202 CONTINUE C C OMIT THE TRA IF NO PATH TO IT C 20204 REGV(RH) = DEFRH REGV(RL) = DEFRL 20205 IF (REGV(RH).NE.-255) GO TO 20206 CALL DELETE(1) GO TO 99991 20206 CONTINUE IF (IT.NE.3.OR.IOP.NE.1) GO TO 20208 C WE HAVE A TRA TO THE OUTER BLOCK... J = CONTRL(47) IF ((PRSP.EQ.0).OR.(J.EQ.1)) GO TO 20208 IF (J.NE.0) GO TO 20207 J = LXIS LXIS = CODLOC + 1 20207 CALL EMIT(LXI,RSP,MOD(J,65536)) C 20208 J = -SYMBOL(I) M = RIGHT(SHR(J,2),14) C CONNECT ENTRY INTO CHAIN K = CODLOC + 1 IF (IOP.EQ.4) K = CODLOC C IOP = 4 IF WE ARRIVED HERE FROM CASE TABLE JMP SYMBOL(I) = -(SHL(SHR(J,16),16) + SHL(K,2) + RIGHT(J,2)) C C CHECK FOR SINGLE REFERENCE J = SYMBOL(I-1) K = IABS(J)/256 IF (K.NE.1) GO TO 20300 C MAKE SURE THIS IS THE FIRST FWD REFERENCE L = SYMBOL(I-2) IF (L .NE. 0) GO TO 20220 C SAVE H AND L, MARK AS A FORWARD REFERENCE C / 1B / 1B / 9B / 8B / C /H VALID/L VALID/H VALUE/L VALUE/ K = 0 L = REGV(7) IF ((L.LT.0).OR.(L.GT.255)) GO TO 20210 K = L + 131072 20210 L = REGV(6) IF ((L.LT.0).OR.(L.GT.511)) GO TO 20220 K = (L + 1024) * 256 + K 20220 SYMBOL(I-2) = K C C TRA, TRC, PRO, AX2 (CASE TRA) 20300 GO TO (20400,20500,20600,20650),IOP C 20400 CONTINUE C MAY BE INC TRA COMBINATION IN DO-LOOP IF ((LASTIN+1).NE.CODLOC) GO TO 20410 C CHANGE TO JFZ TO TOP OF LOOP CALL EMIT(JMC,FAL*32+ZERO,M) CALL DELETE(1) GO TO 99991 20410 XFRLOC = CODLOC XFRSYM = ST(SP) TSTLOC = CODLOC+3 CALL EMIT(JMP,M,0) CALL DELETE(1) C MARK H AND L NIL (= - 255) 20550 REGV(6) = -255 REGV(7) = -255 GO TO 99991 C 20500 CONLOC = CODLOC CALL EMIT(JMC,IOP2,M) CALL DELETE(2) GO TO 99991 C 20600 XFRLOC = CODLOC XFRSYM = ST(SP) TSTLOC = CODLOC+3 CALL EMIT(CAL,M,0) C ADJUST THE MAXDEPTH, IF NECESSARY J = SYMBOL(I-3) + 1 C J IS NUMBER OF DOUBLE-BYTE STACK ELEMENTS REQD CALL STACK(J) C NOW RETURNED FROM CALL SO... CURDEP(PRSP+1) = CURDEP(PRSP+1) - J C C NOW FIX THE H AND L VALUES UPON RETURN J = SYMBOL(I-2) K = SHR(J,19) C MAY BE UNCHANGED FROM CALL IF (K.EQ.3) GO TO 20610 C COMPARE VALUES J = RIGHT(J,19) L = MOD(J,256) J = J / 256 K = MOD(J,512) J = J/512 IF (MOD(J,2).NE.1) L = -1 IF (MOD(J/2,2).NE.1) K = -1 REGV(6) = K REGV(7) = L 20610 CONTINUE CALL DELETE(1) C MAY HAVE TO CONSTRUCT A RETURNED C VALUE AT THE STACK TOP J = SYMBOL(I-1) J = MOD(J/16,16) IF (J.LE.0) GO TO 99991 C SET STACK TOP TO PRECISION OF PROCEDURE SP = SP + 1 PREC(SP) = J ST(SP) = 0 I = RC IF (J.GT.1) I = RB*16+I RASN(SP) = I REGS(RA) = RC REGS(RC) = SP IF (J.GT.1) REGS(RB) = SP LITV(SP) = -1 GO TO 99991 C CAME FROM A CASE VECTOR 20650 CALL EMIT(0,MOD(M,256),0) CALL EMIT(0,M/256,0) CALL DELETE(1) GO TO 99991 C C JUMP TO COMPUTED LOCATION 20700 CALL LOADV(SP,4) CALL DELETE(1) CALL EMIT(PCHL,0,0) C PC HAS BEEN MOVED, SO MARK H AND L UNKNOWN REGV(RH) = -255 REGV(RL) = -255 GO TO 99991 C TRC 21000 CONTINUE J = SP - 1 I = LITV(J) IF(RIGHT(I,1).NE.1) GO TO 21100 C THIS IS A DO FOREVER (OR SOMETHING SIMILAR) SO IGNORE THE JUMP CALL DELETE(2) GO TO 99991 C C NOT A LITERAL '1' 21100 IOP = 2 C CHECK FOR CONDITION CODE I = RASN(J) IF (I.LE.255) GO TO 21200 C ACTIVE CONDITION CODE, CONSTRUCT MASK FOR JMC I = I / 256 J = I / 16 I = MOD(I,16) IOP2 = (FAL + 1 - J)*32 + (CARRY + I - 1) GO TO 20050 C C OTHERWISE NOT A CONDITION CODE, CONVERT TO CARRY 21200 CONTINUE IF (I.NE.0) GO TO 21300 C LOAD VALUE TO ACCUMULATOR PREC(J) = 1 CALL LOADV(J,1) GO TO 21400 C C VALUE ALREADY LOADED 21300 I = MOD(I,16) J = REGS(1) IF (J.EQ.I) GO TO 21400 IF (J.NE.0) CALL EMIT(LD,J,RA) CALL EMIT(LD,RA,I) C 21400 REGS(1) = 0 CALL EMIT(ROT,CY,RGT) IOP2 = FAL*32 + CARRY GO TO 20050 C C PRO C C ROL ROR SHL SHR C SCL SCR C TIME HIGH LOW INPUT C OUTPUT LENGTH LAST MOVE C DOUBLE DEC C 22000 CONTINUE I = ST(SP) IF (I.GT.INTBAS) GO TO 22500 C THIS IS A BUILT-IN FUNCTION. CALL DELETE(1) IF (I.LT.FIRSTI) GO TO 22499 I = I - FIRSTI + 1 C GO TO ( 22300, 22300, 22300, 22300, * 22300,22300, 1 22200, 22300, 22300, 22050, 2 22100, 22310, 22310, 22499, 3 22320,22350),I C INPUT(X) 22050 CONTINUE C INPUT FUNCTION. GET INPUT PORT NUMBER I = LITV(SP) IF ((I.LT.0).OR.(I.GT.255)) GO TO 22499 CALL DELETE(1) SP = SP + 1 CALL GENREG(1,J,K) IF (J.EQ.0) GO TO 22499 K = REGS(1) IF (K.NE.0) CALL EMIT(LD,K,RA) REGS(1) = J RASN(SP) = J LITV(SP) = -1 ST(SP) = 0 PREC(SP) = 1 REGS(J) = SP CALL EMIT(INP,I,0) GO TO 99991 C C OUTPUT(X) 22100 CONTINUE C CHECK FOR PROPER OUTPUT PORT NUMBER I = LITV(SP) IF ((I.LT.0).OR.(I.GT.255)) GO TO 22499 CALL DELETE(1) SP = SP + 1 C NOW BUILD AN ENTRY WHICH CAN BE RECOGNIZED BY C OPERAT. LITV(SP) = I RASN(SP) = 0 PREC(SP) = 1 ST(SP) = OUTLOC GO TO 99991 C TIME(X) 22200 CONTINUE IF (RASN(SP).GT.255) CALL CVCOND(SP) C C EMIT THE FOLLOWING CODE SEQUENCE FOR 100 USEC PER LOOP C 8080 CPU ONLY C (GET TIME PARAMETER INTO THE ACCUMULATOR) C MVI B,12 (7 CY OVERHEAD) C START MOV C,B (5 CY * .5 USEC = 2.5 USEC) C -------------------- C TIM180 DCR C (5 CY * .5 USEC = 2.5 USEC) C JNZ TIM180 (10 CY* .5 USEC = 5.0 USEC) C -------------------- C 12 * (15 CY* .5 USEC = 7.5 USEC) C = (180 CY* .5 USEC = 90 USEC) C DCR A (5 CY * .5 USEC = 2.5 USEC) C JNZ START (10 CY* .5 USEC = 5.0 USEC) C C TOTAL TIME (200 CY*.5 USEC = 100 USEC/LOOP) C J = REGS(RA) I = RASN(SP) IP = I/16 I = MOD(I,16) IF ((J.NE.0).AND.(J.EQ.I)) GO TO 22210 C GET TIME PARAMETER INTO THE ACCUMULATOR IF ((J.NE.0).AND.(J.NE.IP)) CALL EMIT(LD,J,RA) REGS(RA) = 0 IF (I.EQ.0) CALL LOADV(SP,1) I = MOD(RASN(SP),16) IF (J.NE.0) CALL EMIT(LD,RA,I) 22210 REGS(RA) = 0 CALL EMIT(LD,I-1,-12) CALL EMIT(LD,I,I-1) CALL EMIT(DC,I,0) CALL EMIT(JMC,FAL*32+ZERO,CODLOC-1) CALL EMIT(DC,RA,0) CALL EMIT(JMC,FAL*32+ZERO,CODLOC-6) C CALL DELETE(1) GO TO 99991 C STOP HERE BEFORE GOING TO THE UNARY OPERATORS C ** NOTE THAT THIS DEPENDS UPON FIXED RTL = 37 ** 22300 CONTINUE VAL = 36 + I IF (VAL.LE.42) GO TO 22307 C ** NOTE THAT THIS ALSO ASSUMES ONLY 6 SUCH BIFS 22305 CALL UNARY(VAL) GO TO 99991 C C MAY HAVE TO ITERATE 22307 CONTINUE I = LITV(SP) IF (I.LE.0) GO TO 22308 C GENERATE IN-LINE CODE FOR SHIFT COUNTS OF C 1 OR 2 FOR ADDRESS VALUES C 1 TO 3 FOR SHR OF BYTE VALUES C 1 TO 6 FOR ALL OTHER SHIFT FUNCTIONS ON BYTE VALUES J = 6 IF (VAL.EQ.40) J = 3 IF (PREC(SP-1).NE.1) J = 2 IF (I.GT.J) GO TO 22308 CALL DELETE(1) DO 22306 J = 1, I CALL UNARY(VAL) 22306 CONTINUE GO TO 99991 C BUILD A SMALL LOOP AND COUNT DOWN TO ZERO 22308 CONTINUE CALL EXCH C LOAD THE VALUE TO DECREMENT CALL LOADV(SP-1,0) J = RASN(SP-1) J = MOD(J,16) IF (REGS(RA).NE.J) GO TO 22311 CALL EMIT(LD,J,RA) REGS(RA) = 0 22311 CONTINUE LOCK(J) = 1 C LOAD THE VALUE WHICH IS TO BE OPERATED UPON KP = PREC(SP) I = 1 IF (KP.GT.1) I = 0 IF (RASN(SP).NE.0) GO TO 22312 CALL LOADV(SP,I) IF (I.EQ.1) REGS(1) = MOD(RASN(SP),16) 22312 K = RASN(SP) M = MOD(K,16) K = K/16 JP = REGS(RA) IF (I.EQ.1.AND.JP.EQ.M) GO TO 22314 IF (JP.EQ.0) GO TO 22313 CALL EMIT(LD,JP,RA) REGS(RA) = 0 22313 IF (I.EQ.0) GO TO 22314 CALL EMIT(LD,RA,M) REGS(RA) = M 22314 CONTINUE I = CODLOC CALL UNARY(VAL) IF (KP.EQ.1) GO TO 22309 K = REGS(1) IF (K.NE.0) CALL EMIT(LD,K,RA) REGS(1) = 0 22309 CALL EMIT(DC,J,0) CALL EMIT(JMC,FAL*32+ZERO,I) C END UP HERE AFTER OPERATION COMPLETED CALL EXCH LOCK(J) = 0 CALL DELETE(1) GO TO 99991 C C LENGTH AND LAST C ** NOTE THAT THIS ASSUMES THAT LENGTH AND LAST ARE C BUILT-IN FUNCTIONS 10 AND 11 ** 22310 CONTINUE J = ST(SP) IF (J.LE.0) GO TO 22499 J = SYMBOL(J)-1 J = IABS(SYMBOL(J))/256+12-I CALL DELETE(1) SP = SP + 1 ST(SP) = 0 I = 1 IF (J.GT.255) I=2 PREC(SP) = I RASN(SP) = 0 LITV(SP) = J IF (J.LT.0) GO TO 22499 GO TO 99991 C C DOUBLE 22320 CONTINUE IF(PREC(SP).GT.1) GO TO 99999 IF(RASN(SP).NE.0) GO TO 22330 IF(LITV(SP).LT.0) GO TO 22332 PREC(SP) = 2 ST(SP) = 0 GO TO 99991 C LOAD VALUE TO ACCUMULATOR AND GET A REGISTER 22332 CALL LOADV(SP,1) REGS(1) = MOD(RASN(SP),16) C 22330 IA = RASN(SP) PREC(SP) = 2 ST(SP) = 0 IF (IA.GT.15) GO TO 99991 LOCK(IA) = 1 IB = IA - 1 REGS(IB) = SP LOCK(IA) = 0 RASN(SP) = IB*16 + IA C ZERO THE REGISTER CALL EMIT(LD,IB,0) IF (IB.NE.0) GO TO 99991 CALL ERROR(133,5) GO TO 99991 C C C DEC 22350 CONTINUE J = MOD(RASN(SP),16) IF (J.EQ.0) GO TO 22499 IF (PREC(SP).NE.1) GO TO 22499 I = REGS(RA) IF (I.EQ.J) GO TO 22370 C MAY BE A PENDING REGISTER STORE IF (I.NE.0) CALL EMIT(LD,I,RA) CALL EMIT(LD,RA,J) REGS(RA) = J 22370 CALL EMIT(DAA,0,0) GO TO 99991 C C BUILT IN FUNCTION ERROR 22499 CALL ERROR(136,1) GO TO 99999 C C PASS THE LAST TWO (AT MOST) PARAMETERS IN THE REGISTERS C 22500 I = RIGHT(ST(SP),16) I = SYMBOL(I) I = SHR(SYMBOL(I-1),8) I = IMIN(I,2) IF (I.LT.1) GO TO 22630 J = SP - I - I DO 22520 K = 1, I IP = RASN(J) JP = MOD(IP/16,16) IP = MOD(IP,16) IF (IP.NE.0) LOCK(IP) = 1 IF (JP.NE.0) LOCK(JP) = 1 PREC(J) = IMIN(PREC(J),PREC(J+1)) IF (PREC(J).GT.1.OR.JP.EQ.0) GO TO 22510 REGS(JP) = 0 LOCK(JP) = 0 JP = 0 IF (REGS(1).EQ.IP) LOCK(1) = 1 IF (REGS(1).EQ.JP) LOCK(1) = 1 22510 RASN(J) = JP*16+IP J = J + 2 22520 CONTINUE J = SP - 1 - I - I IT = 0 C STACK ANY STUFF WHICH DOES NOT GO TO THE PROCEDURE DO 22530 K=1,SP C CHECK FOR VALUE TO PUSH JP = RASN(K) IF (JP.EQ.0) GO TO 22524 C POSSIBLE PUSH IF NOT A PARAMETER IF (K.GT.J) GO TO 22530 C REGISTERS MUST BE PUSHED JPH = JP/16 KP = REGS(RA) JP = MOD(JP,16) IF (KP.EQ.0) GO TO 22522 C PENDING ACC STORE, CHECK HO AND LO REGISTERS IF (KP.NE.JPH) GO TO 22521 C PENDING HO BYTE STORE CALL EMIT(LD,JPH,RA) REGS(RA) = 0 GO TO 22522 C CHECK LO BYTE 22521 IF (KP.NE.JP) GO TO 22522 CALL EMIT (LD,JP,RA) REGS(RA) = 0 22522 CALL EMIT(PUSH,JP-1,0) CALL STACK(1) ST(K) = 0 IT = RASN(K) JP = MOD(IT,16) IF (JP.NE.0) REGS(JP) = 0 JP = IT/16 IF (JP.NE.0) REGS(JP) = 0 RASN(K) = 0 LITV(K) = -1 IT = K GO TO 22530 C REGISTERS NOT ASSIGNED - CHECK FOR STACKED VALUE 22524 IF ((ST(K).NE.0).OR.(LITV(K).GE.0)) GO TO 22530 IF (IT.EQ.0) GO TO 22530 CALL ERROR(150,1) 22530 CONTINUE 22550 IT = RH J = SP - I - I DO 22590 K = 1, I ID = K + K + 2 IP = RASN(J) JP = MOD(IP/16,16) IP = MOD(IP,16) 22560 ID = ID - 1 IF (IP.EQ.0) GO TO 22590 IF (IP.EQ.ID) GO TO 22580 IF (REGS(ID).EQ.0) GO TO 22570 M = REGS(ID) ML = RASN(M) MH = MOD(ML/16,16) ML = MOD(ML,16) IF (ML.EQ.ID) ML = IT IF (MH.EQ.ID) MH = IT CALL EMIT(LD,IT,ID) REGS(IT) = M RASN(M) = MH*16+ML IT = IT + 1 22570 REGS(IP) = 0 LOCK(IP) = 0 IF (REGS(1).NE.IP) GO TO 22575 IP = 1 REGS(1) = 0 LOCK(1) = 0 22575 CALL EMIT(LD,ID,IP) REGS(ID) = J 22580 LOCK(ID) = 1 IP = JP IF (IP.EQ.-1) GO TO 22590 JP = -1 GO TO 22560 22590 J = J + 2 J = SP - I - I DO 22600 K = 1, I IF (RASN(J).EQ.0) CALL LOADV(J,0) IP = K + K REGS(IP) = J LOCK(IP) = 1 IF (PREC(J+1).EQ.2.AND.PREC(J).EQ.1) CALL EMIT(LD,IP,0) J = J + 2 22600 CONTINUE IF (REGS(1).NE.0) CALL EMIT(LD,REGS(1),RA) DO 22610 K = 1, 7 REGS(K) = 0 REGV(K) = -1 LOCK(K) = 0 22610 CONTINUE J = I + I DO 22620 K = 1, J CALL EXCH IF ((ST(SP).NE.0).OR.(RASN(SP).NE.0).OR. 1 (LITV(SP).GE.0)) GO TO 22615 CALL EMIT(POP,RH,0) CALL USTACK REGV(RH) = -1 REGV(RL) = -1 22615 CALL DELETE(1) 22620 CONTINUE IOP = 3 GO TO 20050 22630 CONTINUE LOCK(6) = 1 LOCK(7) = 1 CALL SAVER LOCK(6) = 0 LOCK(7) = 0 IOP = 3 GO TO 20050 C C RET 23000 CONTINUE JP = PRSP IF (JP.GT.0) GO TO 23050 CALL ERROR(146,1) GO TO 20550 23050 CONTINUE C CHECK FOR TYPE AND PRECISION OF PROCEDURE L = MOD(PRSTK(JP),65536) + 1 L = SYMBOL(L)/16 L = MOD(L,16) C L IS THE PRECISION OF THE PROCEDURE IF (L.EQ.0) GO TO 23310 I = RASN(SP) IF (I.EQ.0) CALL LOADV(SP,1) IF (I.GE.256) CALL CVCOND(SP) K = RASN(SP) JP = REGS(1) J = MOD(K,16) K = K/16 IF ((I.EQ.0).OR.(J.EQ.JP)) GO TO 23200 C HAVE TO LOAD THE ACCUMULATOR. MAY HAVE H.O. BYTE. IF ((JP.EQ.0).OR.(JP.NE.K)) GO TO 23150 CALL EMIT(LD,K,RA) 23150 CALL EMIT(LD,RA,J) C 23200 IF (K.EQ.0) GO TO 23300 IF (K.NE.RB) CALL EMIT(LD,RB,K) 23300 CONTINUE C COMPARE PRECISION OF PROCEDURE WITH STACK IF (L.GT.PREC(SP)) CALL EMIT(LD,RB,0) 23310 CALL DELETE(1) IF (PRSTK(PRSP).LE.65535) GO TO 23320 C INTERRUPT PROCEDURE - USE THE DRT CODE BELOW JP = PRSP K = 0 GO TO 45020 23320 CALL EMIT(RTN,0,0) C MERGE VALUES OF H AND L FOR THIS PROCEDURE C CAN ALSO ENTER WITH JP SET FROM END OF PROCEDURE JP = PRSP 23350 XFRLOC = CODLOC-1 XFRSYM = 0 TSTLOC = CODLOC I = MOD(PRSTK(JP),65536) JP = SYMBOL(I) K = REGV(6) L = REGV(7) J = RIGHT(JP,19) JP = SHR(JP,19) IF (JP.NE.3) GO TO 23360 IF ((K.EQ.-254).AND.(L.EQ.-254)) GO TO 99991 C H AND L HAVE BEEN ALTERED IN THE PROCEDURE KP = K LP = L GO TO 23370 C OTHERWISE MERGE VALUES OF H AND L C 23360 LP = MOD(J,256) J = J / 256 KP = MOD(J,512) J = J/512 IF (MOD(J,2).EQ.0) LP = -1 IF (MOD(J/2,2).EQ.0) KP = -1 C COMPARE K WITH KP AND L WITH LP 23370 J = 0 IF ((L.GE.0).AND.(LP.EQ.L)) J = 131072+L IF ((K.GE.0).AND.(KP.EQ.K)) J = (K+1024) * 256 + J SYMBOL(I) = J C MARK H AND L NIL BEFORE RETURNING FROM SUBR GO TO 20550 C C STO AND STD 24000 I = ST(SP) C CHECK FOR OUTPUT FUNCTION IF (I.EQ.OUTLOC) GO TO 24050 C CHECK FOR COMPUTED ADDRESS OR SAVED ADDRESS IF (I.GE.0) GO TO 24100 C CHECK FOR ADDRESS REFERENCE OUTSIDE INTRINSIC RANGE I = -I IF (I.GT.INTBAS) GO TO 24100 C CHECK FOR 'MEMORY' ADDRESS REFERENCE C ** NOTE THAT STACKTOP MUST BE AT 6 ** IF (I.LE.6) GO TO 24100 IF (I.EQ.5) GO TO 24100 C IGNORE THE STORE FOR INTRINSIC PARAMETERS GO TO 24200 C OUTPUT FUNCTION 24050 CONTINUE J = LITV(SP) I = RASN(SP-1) IF ((I.GT.0) .AND. (I.LT.256)) GO TO 24060 C LOAD VALUE TO ACC I = REGS(RA) IF (I.GT.0) CALL EMIT(LD,I,RA) CALL LOADV(SP-1,1) I = RASN(SP-1) GO TO 24070 C OPERAND IS IN THE GPRS 24060 I = MOD(I,16) K = REGS(RA) IF ((K.GT.0).AND.(K.NE.I))CALL EMIT(LD,K,RA) IF (K.NE.I) CALL EMIT(LD,RA,I) C NOW MARK ACC ACTIVE IN CASE SUBSEQUENT STO OPERATOR 24070 REGS(RA) = MOD(I,16) CALL EMIT(OUT,J,0) CALL DELETE(1) GO TO 24200 24100 I= 1 C CHECK FOR STD IF (VAL.EQ.25) I = 0 CALL GENSTO(I) C * CHECK FOR STD * 24200 IF(VAL.EQ.25) CALL DELETE(1) GO TO 99991 C XCH 26000 CALL EXCH GO TO 99991 C DEL 27000 CONTINUE IF ((ST(SP).NE.0).OR.(RASN(SP).NE.0).OR.(LITV(SP).GE.0)) 1 GO TO 27100 C VALUE IS STACKED, SO GET RID OF IT CALL EMIT(POP,RH,0) REGV(RH) = -1 REGV(RL) = -1 CALL USTACK 27100 CALL DELETE(1) GO TO 99991 C C CAT (INLINE DATA FOLLOWS) 28000 CONTINUE CALL INLDAT GO TO 99999 C C LOD 29000 CONTINUE IL = 0 K = PREC(SP) C MAY BE A LOD FROM A BASE FOR A BASED VARIABLE PREC(SP) = MOD(K,4) IA = RASN(SP) IF (IA.GT.0) GO TO 29050 C CHECK FOR SIMPLE BASED VARIABLE CASE I = ST(SP) IF (I.LE.0) GO TO 29010 C RESERVE REGISTERS FOR THE RESULT CALL GENREG(2,IA,IB) REGS(IA) = SP REGS(IB) = SP RASN(SP) = IB*16 + IA C MAY BE ABLE TO SIMPLIFY LHLD LP = REGV(RH) L = REGV(RL) IF ((LP.EQ.-3).AND.(-L.EQ.I)) GO TO 29110 IF ((LP.EQ.-4).AND.(-L.EQ.I)) GO TO 29007 J = CHAIN(I,CODLOC+1) CALL EMIT(LHLD,J,0) REGV(RH) = -3 REGV(RL) = -I GO TO 29110 29007 CALL EMIT(DCX,RH,0) REGV(RH) = -3 GO TO 29110 C 29010 CONTINUE C FIRST CHECK FOR AN ADDRESS REFERENCE IF (ST(SP).EQ.0) GO TO 29011 C CHANGE THE ADDRESS REFERENCE TO A VALUE REFERENCE ST(SP) = -ST(SP) LITV(SP) = -1 GO TO 99991 C LOAD THE ADDRESS 29011 CONTINUE CALL LOADV(SP,0) IA = RASN(SP) 29050 IB = IA/16 IA = MOD(IA,16) I = REGS(1) IF (IA.EQ.I) IA = 1 IF (IB.EQ.I) IB = 1 IF (IB.EQ.(IA-1)) IL = IB IF ((IA*IB).NE.0) GO TO 29100 CALL ERROR(138,5) GO TO 99991 29100 CONTINUE C MAY BE POSSIBLE TO USE LDAX OR XCHG IF (IL.NE.RD) GO TO 29105 C POSSIBLE XCHG OR LDAX IF (LASTEX.EQ.(CODLOC-1)) GO TO 29102 C LAST INSTRUCTION NOT AN XCHG IF (MOD(PREC(SP),2).EQ.1) GO TO 29110 C DOUBLE XCHG OR DOUBLE BYTE LOAD WITH ADDR IN D AND E 29102 CALL EMIT(XCHG,0,0) GO TO 29107 C 29105 CONTINUE CALL EMIT(LD,RL,IA) CALL EMIT(LD,RH,IB) 29107 IL = 0 REGV(RH) = -1 REGV(RL) = -1 29110 I = PREC(SP) - K/4 PREC(SP) = I C RECOVER THE REGISTER ASSIGNMENT FROM RASN IB = RASN(SP) IA = MOD(IB,16) IB = IB/16 J = REGS(1) K = J*(J-IA)*(J-IB) C JUMP IF J=0, IA, OR IB IF (K.EQ.0) GO TO 29150 CALL EMIT(LD,J,RA) C SET PENDING STORE OPERATION IN REGS(1) 29150 CONTINUE C MAY BE ABLE TO CHANGE REGISTER ASSIGNMENT TO BC IF (IA.NE.RE) GO TO 29160 IF ((REGS(RB).NE.0).OR.(REGS(RC).NE.0)) GO TO 29160 C BC AVAILABLE, SO RE-ASSIGN REGS(IA) = 0 REGS(IB) = 0 REGS(RB) = SP REGS(RC) = SP IA = RC IB = RB RASN(SP) = RB*16+RC 29160 REGS(RA) = IA IF (IL.EQ.0) CALL EMIT(LD,RA,ME) IF (IL.NE.0) CALL EMIT(LDAX,IL,0) IF (I.GT.1) GO TO 29200 C SINGLE BYTE LOAD - RELEASE H.O. REGISTER IB = RASN(SP) RASN(SP) = MOD(IB,16) IB = IB/16 IF (IB.EQ.REGS(1)) REGS(1) = 0 REGS(IB) = 0 REGV(IB) = -1 GO TO 29300 C 29200 CALL EMIT(INCX,RH,0) C MAY HAVE DONE A PREVOUS LHLD, IF SO MARK INCX H IF (REGV(RH).EQ.-3) REGV(RH) = -4 CALL EMIT(LD,IB,ME) 29300 CONTINUE REGS(6) = 0 REGS(7) = 0 ST(SP) = 0 GO TO 99991 C C INC 31000 CONTINUE C PLACE A LITERAL 1 AT STACK TOP AND APPLY ADD OPERATOR SP = SP + 1 LITV(SP) = 1 C CHECK FOR SINGLE BYTE INCREMENT, MAY BE COMPARING WITH 255 IF (PREC(SP-1).NE.1) GO TO 1000 CALL APPLY(AD,AC,1,1) LASTIN = CODLOC C TRA WILL NOTICE LASTIN = CODLOC AND SUBSTITUTE JFZ GO TO 99991 C C CSE (CASE STATEMENT INDEX) 32000 CONTINUE C LET X BE THE VALUE OF THE STACK TOP C COMPUTE 2*X + CODLOC, FETCH TO HL, AND JUMP WITH PCHL C RESERVE REGISTERS FOR THE JUMP TABLE BASE CALL GENREG(2,IA,IB) LOCK(IA) = 1 LOCK(IB) = 1 C INDEX IS IN H AND L, SO DOUBLE IT CALL EMIT(DAD,RH,0) C NOW LOAD THE VALUE OF TABLE BASE, DEPENDING UPON 9 BYTES C LXI R X Y, DAD R, MOV EM, INX H, MOV DM XCHG PCHL CALL EMIT(LXI,IB,CODLOC+9) CALL EMIT(DAD,IB,0) CALL EMIT(LD,RE,ME) CALL EMIT(INCX,RH,0) CALL EMIT(LD,RD,ME) CALL EMIT(XCHG,0,0) CALL EMIT(PCHL,0,0) C PHONEY ENTRY IN SYMBOL TABLE TO KEEP CODE DUMP CLEAN SYTOP = SYTOP + 1 SYMBOL(SYTOP) = SYINFO SYMBOL(SYINFO) = -CODLOC SYINFO = SYINFO - 1 C SET ENTRY TO LEN=0/PREC=2/TYPE=VARB/ SYMBOL(SYINFO) = 32+VARB CASJMP = SYINFO C CASJMP WILL BE USED TO UPDATE THE LENGTH FIELD SYINFO = SYINFO - 1 IF (SYINFO.LE.SYTOP) CALL ERROR(108,5) C LOCK(IB) = 0 REGV(RH) = -1 REGV(RL) = -1 C MARK H AND L NIL AT CASE OR COMPUTED JUMP BEFORE RETURNING GO TO 20550 C HAL (HALT) 36000 CONTINUE CALL EMIT(EI,0,0) CALL EMIT(HALT,0,0) GO TO 99991 C C RTL RTR SFL SFR 37000 CONTINUE CALL UNARY(VAL) GO TO 99991 C C CVA (CONVERT ADDRESS TO DOUBLE PRECISION VARIABLE) 43000 CONTINUE C CVA MUST BE IMMEDIATELY PRECEDED BY AN INX OR ADR REF PREC(SP) = 2 C IF THE ADDRESS IS ALREADY IN THE GPR'S THEN NOTHING TO DO IF (RASN(SP).GT.0) GO TO 99991 IF (ST(SP).LT.0) GO TO 43100 IF (ST(SP).GT.0) GO TO 43050 CALL ERROR(139,1) GO TO 99999 C C LOAD VALUE OF BASE FOR ADDRESS REF TO A BASED VARIABLE 43050 CALL LOADV(SP,3) GO TO 99991 C C CHECK FOR ADDRESS REF TO DATA IN ROM. 43100 JP = LITV(SP) IF (JP.GT.65535) GO TO 43190 IF (JP.LT.0) CALL ERROR(149,1) C LEAVE LITERAL VALUE ST(SP) = 0 GO TO 99991 C C DO LXI R WITH THE ADDRESS 43190 CALL GENREG(2,IA,IB) IF (IA.GT.0) GO TO 43200 CALL ERROR(140,5) GO TO 99999 C 43200 J = CHAIN(-ST(SP),CODLOC+1) CALL EMIT(LXI,IB,J) ST(SP) = 0 RASN(SP) = IB*16+IA REGS(IA) = SP REGS(IB) = SP GO TO 99991 C C C ORG 44000 CONTINUE I = LITV(SP) IF (CODLOC.LE.I) GO TO 44100 CALL ERROR(141,1) C 44100 J = CONTRL(47) K = 3 IF (J.EQ.1) K = 0 IF (CODLOC.NE.(OFFSET+PREAMB+K)) GO TO 44200 C THIS IS THE START OF PROGRAM, CHANGE OFFSET OFFSET = I - PREAMB CODLOC = I + K IF (LXIS.GT.0) LXIS = CODLOC - 2 C WE HAVE ALREADY GENERATED LXI SP (IF ANY) GO TO 99990 C SOME CODE HAS BEEN GENERATED, SO LXI IF NECESSARY 44200 IF (CODLOC.GE.I) GO TO 44300 CALL EMIT(0,0,0) GO TO 44200 C 44300 IF (J.EQ.1) GO TO 99990 IF (J.GT.1) GO TO 44400 J = LXIS LXIS = CODLOC + 1 44400 CALL EMIT(LXI,RSP,J) GO TO 99990 C C DRT (DEFAULT RETURN FROM SUBROUTINE) C MERGE H AND L VALUES USING RET OPERATION ABOVE 45000 CONTINUE JP = PRSP IF (PRSTK(JP).LE.65535) GO TO 45005 C THIS IS THE END OF AN INTERRUPT PROCEDURE CURDEP(JP+1) = CURDEP(JP+1) - 4 45005 CONTINUE IF (PRSP.GT.0) PRSP = PRSP - 1 C GET STACK DEPTH FOR SYMBOL TABLE IF (JP.LE.0) GO TO 45010 IF (CURDEP(JP+1).NE.0) CALL ERROR(150,1) K = MAXDEP(JP+1) L = MOD(PRSTK(JP),65536) - 1 C K IS MAX STACK DEPTH, L IS SYMBOL TABLE COUNT ENTRY SYMBOL(L) = K 45010 K = REGV(6) L = REGV(7) IF ((K.EQ.-255).AND.(L.EQ.-255)) GO TO 99999 IF (PRSTK(JP).LE.65535) GO TO 45030 45020 CONTINUE C POP INTERRUPTED REGISTERS AND ENABLE INTERRUPTS CALL EMIT(POP,RA,0) CALL EMIT(POP,RB,0) CALL EMIT(POP,RD,0) CALL EMIT(POP,RH,0) CALL EMIT(EI,0,0) 45030 CALL EMIT(RTN,0,0) IF ((K.EQ.-254).AND.(L.EQ.-254)) GO TO 20550 IF (JP.GT.0) GO TO 23350 CALL ERROR(146,1) GO TO 20550 C C ENA - ENABLE INTERRUPTS 45100 CONTINUE CALL EMIT(EI,0,0) GO TO 99999 C DIS - DISABLE INTERRUPTS 45200 CONTINUE CALL EMIT(DI,0,0) GO TO 99999 C C AX1 - CASE BRANCH TO CASE SELECTOR 45500 CONTINUE C LOAD CASE NUMBER TO H AND L CALL EXCH CALL LOADV(SP,4) CALL DELETE(1) REGV(RH) = -1 REGV(RL) = -1 C USE TRA CODE GO TO 20000 C C MAY NOT BE OMITTED EVEN THOUGH NO OBVIOUS PATH EXISTS). 46000 IOP = 4 C CASJMP POINTS TO SYMBOL TABLE ATTRIBUTES - INC LEN FIELD SYMBOL(CASJMP) = SYMBOL(CASJMP) + 256 GO TO 20050 88887 IOP2 = IOP 88888 CALL APPLY (IOP,IOP2,ICOM,ICY) GO TO 99991 99990 SP = SP - 1 99991 ALTER = 1 99999 RETURN END SUBROUTINE SYDUMP C DUMP THE SYMBOL TABLE FOR THE SIMULATOR INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER GNC,RIGHT,SHL,SHR,GET INTEGER CHAR(32),ICHAR,ADDR C CLEAR THE OUTPUT BUFFER CALL WRITEL(0) L = 0 C SAVE THE CURRENT INPUT FILE NUMBER, POINT INPUT C AT SYMBOL FILE. M = CONTRL(20) CONTRL(20) = CONTRL(32) C GET RID OF LAST CARD IMAGE IBP = 99999 50 I = GNC(0) IF (I.EQ.1) GO TO 50 IF (I.NE.41) GO TO 8000 C C PROCESS NEXT SYMBOL TABLE ENTRY 100 I = GNC(0) IF (I.EQ.41) GO TO 9000 C PROCESS THE NEXT SYMBOL 110 I = I - 2 C BUILD ADDRESS OF INITIALIZED SYMBOL K = 32 DO 200 J=1,2 I = (GNC(0)-2)*K+I 200 K = K * 32 C IF(I.GT.4.AND.I.NE.6) GO TO 260 250 J=GNC(0) IF(J.EQ.41) GO TO 100 GO TO 250 260 CONTINUE C WRITE SYMBOL NUMBER, SYMBOL, AND ABSOLUTE ADDRESS (OCTAL) CALL CONOUT(1,-5,I,10) CALL PAD(1,1,1) ICHAR = 1 DO 290 K = 1,32 CHAR(K) = 40 290 CONTINUE C READ UNTIL NEXT / SYMBOL 300 J = GNC(0) IF (J.EQ.41) GO TO 400 CHAR(ICHAR) = J ICHAR = ICHAR + 1 C WRITE NEXT CHARACTER IN STRING CALL PAD(1,J,1) GO TO 300 C C END OF SYMBOL 400 CALL PAD(1,1,1) C WRITE OCTAL ADDRESS J = SYMBOL(I) I = IABS(SYMBOL(J)) J = SYMBOL(J-1) IF (MOD(J,16).EQ.VARB) GO TO 410 C SYMBOL IS A LABEL, SO SHIFT RIGHT TO GET ADDR I = I/65536 410 CONTINUE CALL CONOUT(1,5,I,16) ADDR = I CALL PAD(1,1,3) IF (CONTRL(13).EQ.0) GO TO 430 N = CONTRL(26) CONTRL(26) = CONTRL(13) CALL WRITEL(0) L = 1 CONTRL(26) = N 430 CONTINUE OBP = CONTRL(36) - 1 IF (CONTRL(24).EQ.0) GO TO 440 CALL FORM(1,CHAR,1,32,32) CALL CONOUT(1,4,ADDR,16) CALL WRITEL(0) 440 CONTINUE GO TO 100 C 8000 CALL ERROR(143,1) C 9000 IF (L.EQ.0) GO TO 9999 IF (CONTRL(13).EQ.0) GO TO 9999 CALL PAD(1,1,1) CALL PAD(1,38,1) N = CONTRL(26) CONTRL(26) = CONTRL(13) CALL WRITEL(0) CONTRL(26) = N C 9999 CONTINUE CONTRL(20) = M RETURN END BLOCK DATA INTEGER TITLE(10),VERS COMMON/TITLES/TITLE,VERS INTEGER PRSTK(15),MAXDEP(16),CURDEP(16),PRSMAX,PRSP,LXIS LOGICAL ERRFLG INTEGER TERR(22) COMMON/TERRR/TERR,ERRFLG INTEGER SMSSG(29) COMMON/SMESSG/SMSSG COMMON /PSTACK/PRSTK,MAXDEP,CURDEP,PRSMAX,PRSP,LXIS C PSTACK IS THE PROCEDURE STACK USED IN HL OPTIMIZATION INTEGER XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL INTEGER LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /PEEP/LAPOL,LASTLD,LASTRG,LASTIN,LASTEX,LASTIR COMMON /XFROPT/XFRLOC,XFRSYM,TSTLOC,CONLOC,DEFSYM,DEFRH,DEFRL C XFROPT IS USED IN BRANCH OPTIMIZTION INTEGER SYMBOL(3000),SYMAX,SYTOP,SYINFO,LMEM COMMON /SYMBL/SYMBOL,SYMAX,SYTOP,SYINFO,LMEM C BUILT-IN FUNCTION CODE (MULTIPLICATION AND DIVISION) INTEGER BIFTAB(41),BIFPAR COMMON /BIFCOD/BIFTAB,BIFPAR INTEGER IBUFF(80),OBUFF(120),IBP,OBP, 1 ITRAN(256),OTRAN(64) COMMON /FILES/IBUFF,OBUFF,IBP,OBP, 1 ITRAN,OTRAN INTEGER CONTRL(64) COMMON /CNTRL/CONTRL INTEGER MSSG(77) COMMON/MESSG/MSSG C INTEGER POLCHR(18),OPCVAL(51) COMMON /OPCOD/POLCHR,OPCVAL C OPRADRVALDEFLITLIN INTEGER INTPRO(8) COMMON /INTER/INTPRO INTEGER DEBASE COMMON /BASE/DEBASE INTEGER INLOC,OUTLOC,FIRSTI,CASJMP COMMON /BIFLOC/INLOC,OUTLOC,FIRSTI,CASJMP INTEGER CTRAN(256),C1(100),C2(100),C3(56) EQUIVALENCE (C1(1),CTRAN(1)),(C2(1),CTRAN(101)), 1 (C3(1),CTRAN(201)) INTEGER INSYM(284),INSYM1(150),INSYM2(134) EQUIVALENCE (INSYM1(1),INSYM(1)), 1 (INSYM2(1),INSYM(151)) INTEGER IBYTES(23) COMMON /INST/CTRAN,INSYM,IBYTES INTEGER CODLOC,ALTER,CBITS(43) COMMON /CODE/CODLOC,ALTER,CBITS INTEGER LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT,JMP,JMC, 1 CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY COMMON /OPS/LD,IN,DC,AD,AC,SU,SB,ND,XR,OR,CP,ROT, 1 JMP,JMC,CAL,CLC,RTN,RTC,RST,INP,OUT,HALT, 2 STA,LDA,XCHG,SPHL,PCHL,CMA,STC,CMC,DAA,SHLD,LHLD,EI,DI, 3 LXI,PUSH,POP,DAD,STAX,LDAX,INCX,DCX, 4 RA,RB,RC,RD,RE,RH,RL,RSP, ME,LFT,RGT,TRU,FAL, 5 CY,ACC,CARRY,ZERO,SIGN,PARITY INTEGER REGS(7),REGV(7),LOCK(7),PREC(16),ST(16),RASN(16),LITV(16), 1 SP,MAXSP,INTBAS COMMON /REGALL/REGS,REGV,LOCK,PREC,ST,RASN,LITV,SP,MAXSP,INTBAS INTEGER REGMAP(9) COMMON /RGMAPP/ REGMAP INTEGER VARB,INTR,PROC,LABEL,LITER COMMON /TYPES/VARB,INTR,PROC,LABEL,LITER INTEGER STHEAD(12) COMMON /STHED/ STHEAD INTEGER OPR,ADR,VLU,DEF,LIT,LIN, *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR, *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC, *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS, *AX1,AX2,AX3 COMMON /ILCOD/ OPR,ADR,VLU,DEF,LIT,LIN, *NOP,ADD,ADC,SUB,SBC,MUL,DIV,MDF,NEG,AND,IOR,XOR,NOT,EQL,LSS,GTR, *NEQ,LEQ,GEQ,INX,TRA,TRC,PRO,RET,STO,STD,XCH,DEL,DAT,LOD,BIF,INC, *CSE,END,ENB,ENP,HAL,RTL,RTR,SFL,SFR,HIV,LOV,CVA,ORG,DRT,ENA,DIS, *AX1,AX2,AX3 INTEGER WDSIZE,WFACT,TWO8,FACT(5) INTEGER MAXMEM,MEMTOP,MEMBOT,MEM(2500),MAXVM,OFFSET,PREAMB COMMON /FACTOR/WDSIZE,WFACT,TWO8,FACT COMMON /MEMORY/MAXMEM,MEMTOP,MEMBOT,MEM,MAXVM,OFFSET,PREAMB C ... PLM2 VERS ... DATA OFFSET/0/ DATA TITLE/27,23,24, 4, 1,33,16,29,30, 1/ DATA VERS/20/ C COMPILATION TERMINATED DATA TERR/14,26,24,27,20,23,12,31,20,26,25, 1, 1 31,16,29,24,20,25,12,31,16,15/ DATA ERRFLG /.FALSE./ C STACK SIZE = OVERRIDDEN BYTES DATA SMSSG /30,31,12,14,22,1, 1 30,20,37,16,1, 39,1, 2 26,33,16,29,29,20,15,15,16,25,1, 3 13,36,31,16,30/ DATA PRSTK /15*0/, PRSMAX /15/, PRSP /0/ DATA MAXDEP /16*0/, CURDEP /16*0/, LXIS /0/ C PEEP IS USED IN PEEPHOLE OPTIMIZATION (SEE EMIT) C LAPOL IS A ONE ELEMENT POLISH LOOK-AHEAD C LASTLD IS CODLOC OF LAST REGISTER TO MEMORY STORE C LASTRG IS THE EFFECTED REGISTER C LASTIN IS THE CODLOC OF THE LAST INCREMENT C (USED IN DO-LOOP INDEX INCREMENT) C LASTEX IS LOCATION OF LAST XCHG OPERATOR C LASTIR IS THE CODLOC OF THE LAST REGISTER INCREMENT C (USED IN APPLY AND GENSTO TO GEN INR MEMORY) DATA LAPOL/-1/, LASTLD/0/, LASTRG/0/, LASTIN /0/, LASTEX /0/, 1 LASTIR /0/ DATA XFRLOC /-1/, XFRSYM /0/, TSTLOC /-1/, CONLOC /-1/, 1 DEFSYM /0/, DEFRH /-1/, DEFRL /-1/ DATA SYMAX /3000/, SYTOP /0/, SYINFO /3000/ DATA BIFPAR /0/ C BUILT-IN FUNCTION VECTOR -- C MULTIPLY AND DIVIDE OR MOD C + FIRST TWO GIVE BASE LOCATIONS OF BIF CODE SEGMENTS C + NEXT COMES NUMBER OF BYTES, NUMBER OF RELOCATIONS, AND C + A VECTOR OF ABSOLUTE LOCATIONS WHERE STUFFS OCCUR C C THE CODE SEGMENTS ARE ABSOLUTE, PACKED THREE PER ENTRY C C C MULTIPLY C C 121 147 120 154 242 012 000 096 105 235 068 077 033 000 000 235 C 120 177 200 235 120 031 071 121 031 079 210 030 000 025 235 041 C 195 016 000 C C DIVIDE C C 122 047 087 123 047 095 019 033 000 000 062 017 229 025 210 018 C 000 227 225 245 121 023 079 120 023 071 125 023 111 124 023 103 C 241 061 194 012 000 183 124 031 087 125 031 095 201 C DATA BIFTAB/ 1 -3, -20, 1 35, 3, 5, 27, 33, 1 7902073, 848538, 6905856, 5063915, 33, 11630827, 1 7924680, 7948063, 13782815, 1638430, 12790251, 16, 1 45, 2, 15, 35, 1 5713786, 6238075, 8467, 1129984, 13769189, 1 14876690, 7992801, 7884567, 8210199, 8154903, 1 15820567, 836157, 8173312, 8214303, 13197087, 1 0, 0, 0/ DATA CONTRL /64*0/ DATA IBP /81/, OBP /0/ DATA OTRAN /1H ,1H0,1H1,1H2,1H3,1H4, 1 1H5,1H6,1H7,1H8,1H9,1HA,1HB,1HC,1HD,1HE,1HF, 2 1HG,1HH,1HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ, 3 1HR,1HS,1HT,1HU,1HV,1HW,1HX,1HY,1HZ, 4 1H$,1H=,1H.,1H/,1H(,1H),1H+,1H-,1H',1H*,1H,, 5 1H<,1H>,1H:,1H;,12*0/ C PASS-NOPROGRAM C ERROR C ()NEARAT C PARSE STACK C SYMBOL ADDR WDS CHRS LENGTH PR TY DATA MSSG /27,12,30,30,45, 1 25,26,27,29,26,18,29,12,24,1, 2 16,29,29,26,29, 3 42,43,25,16,12,29,12,31, 4 27,12,29,30,16,1,30,31,12,14,22,51,1, 5 30,36,24,13,26,23, 1,1, 12,15,15,29, 1, 34,15,30, 1, 6 14,19,29,30, 1,1,1, 23,16,25,18,31,19, 1,27,29, 1,31,36/ DATA INTPRO /8*0/ DATA POLCHR /26,27,29, 12,15,29, 33,12,23, 15,16,17, 1 23,20,31, 23,20,25/ DATA DEBASE /16/ DATA INLOC /16/, OUTLOC /17/, CASJMP /0/, FIRSTI /7/ C NUMBER OF BYTES FOLLOWING FIRST 13 INSTRUCTIONS IN CATEGORY 3 DATA IBYTES /0,0,0,0,2,2,0,0,1,1,0,2,2, 1 0,0,0,0,0,0,0,0,2,2/ DATA C1 / 1 835, 36, 40, 42, 1057, 2081, 1280, 35, 995, 39, 2 41, 43, 1089, 2113, 2304, 67, 995, 100, 104, 106, 3 1121, 2145, 3328, 99, 995, 103, 105, 107, 1153, 2177, 4 4352, 131, 995, 164, 707, 170, 1185, 2209, 5376, 675, 5 995, 167, 739, 171, 1217, 2241, 6400, 579, 995, 292, 6 387, 298, 1249, 2273, 7424, 611, 995, 295, 419, 299, 7 1025, 2049, 256, 643, 1056, 1088, 1120, 1152, 1184, 1216, 8 1248, 1024, 2080, 2112, 2144, 2176, 2208, 2240, 2272, 2048, 9 3104, 3136, 3168, 3200, 3232, 3264, 3296, 3072, 4128, 4160, A 4192, 4224, 4256, 4288, 4320, 4096, 5152, 5184, 5216, 5248/ DATA C2 / 1 5280, 5312, 5344, 5120, 6176, 6208, 6240, 6272, 6304, 6336, 2 6368, 6144, 7200, 7232, 7264, 7296, 7328, 7360, 355, 7168, 3 32, 64, 96, 128, 160, 192, 224, 0, 3105, 3137, 4 3169, 3201, 3233, 3265, 3297, 3073, 4129, 4161, 4193, 4225, 5 4257, 4289, 4321, 4097, 5153, 5185, 5217, 5249, 5281, 5313, 6 5345, 5121, 6177, 6209, 6241, 6273, 6305, 6337, 6369, 6145, 7 7201, 7233, 7265, 7297, 7329, 7361, 7393, 7169, 8225, 8257, 8 8289, 8321, 8353, 8385, 8417, 8193, 9249, 9281, 9313, 9345, 9 9377, 9409, 9441, 9217,10273,10305,10337,10369,10401,10433, A 10465,10241, 3106, 38, 1058, 163, 2082, 37, 3329, 259/ DATA C3 / 1 3234, 227, 1186, 995, 2210, 195, 4353, 1283, 3074, 102, 2 1026, 323, 2050, 101, 5377, 2307, 3202, 995, 1154, 291, 3 2178, 995, 6401, 3331, 3170, 166, 1122, 483, 2146, 165, 4 7425, 4355, 3298, 547, 1250, 451, 2274, 995, 8449, 5379, 5 3138, 6, 1090, 803, 2114, 5, 9473, 6403, 3266, 515, 6 1218, 771, 2242, 995,10497, 7427/ C DATA INSYM1 / 1 15, 38, 60, 66,108,116,234,240,247,253,259,266,273,279, 10, 2 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 38, 12, 13, 14, 15, 3 16, 19, 23, 24, 20, 30, 27, 8, 48, 50, 52, 53, 55, 56, 57, 4 58, 60, 25, 14, 25, 37, 27, 27, 26, 14, 37, 24, 27, 16, 1, 5 63, 66, 24, 26, 33, 10, 78, 81, 84, 87, 90, 93, 96, 99,102, 6 105,108, 20, 25, 29, 15, 14, 29, 12, 15, 15, 12, 15, 14, 30, 7 32, 13, 30, 13, 14, 12, 25, 12, 35, 29, 12, 26, 29, 12, 14, 8 24, 27, 3,113,114,115,116, 21, 14, 29, 31,149,152,155,158, 9 161,164,168,171,174,176,179,182,185,188,192,196,200,204,207, A 210,213,216,220,224,226,228,231,231,231,231,231,234, 29, 23/ DATA INSYM2 / 1 14, 29, 29, 14, 29, 12, 23, 29, 12, 29, 21, 24, 27, 14, 12, 2 23, 23, 29, 16, 31, 29, 30, 31, 20, 25, 26, 32, 31, 19, 23, 3 31, 30, 31, 12, 23, 15, 12, 35, 14, 19, 18, 35, 31, 19, 23, 4 30, 27, 19, 23, 27, 14, 19, 23, 14, 24, 12, 30, 31, 14, 14, 5 24, 14, 15, 12, 12, 30, 19, 23, 15, 23, 19, 23, 15, 16, 20, 6 15, 20, 25, 26, 27, 45, 45, 45, 1,237,240, 23, 35, 20, 1, 7 243,247, 27, 32, 30, 19, 1,250,253, 27, 26, 27, 1,256,259, 8 15, 12, 15, 1,262,266, 30, 31, 12, 35, 1,269,273, 23, 15, 9 12, 35, 1,276,279, 20, 25, 35, 1,282,285, 15, 14, 35/ DATA CODLOC /0/ C STA 011 000 LDA 011 000 XCHG SPHL PCHL C CMA STC CMC DAA SHLD 011 000 LHLD 011 C 000 EI DI LXI B 011 000 PUSH B POP B DAD B C STAX B LDAX B INX B DCX B NOP NOP NOP NOP NOP C 050 011 000 058 011 000 235 249 233 047 055 063 039 034 011 000 C 042 011 000 251 243 001 011 000 197 193 009 002 010 003 011 000 DATA CBITS /64,4,5,128,136,144,152,160,168,176,184,7, 1 195,194,205,196,201,192,199,219,211,118, 2 50,58,235,249,233,47,55,63,39,34,42,251,243,1, 3 197,193,9,2,10,3,11/ DATA LD /1/, IN /2/, DC /3/, AD /4/, AC /5/, SU /6/, 1 SB /7/, ND /8/, XR /9/, OR /10/, CP /11/, ROT /12/, 2 JMP /13/, JMC /14/, CAL /15/, CLC /16/, RTN /17/, RTC /18/, 3 RST /19/, INP /20/, OUT /21/, HALT /22/, 4 STA /23/, LDA /24/, XCHG /25/, SPHL /26/, PCHL /27/, CMA /28/, 5 STC /29/, CMC /30/, DAA /31/, SHLD /32/, LHLD /33/, EI /34/, 6 DI /35/, LXI /36/, PUSH /37/, POP /38/, DAD /39/, STAX /40/, 7 LDAX /41/, INCX /42/, DCX /43/ DATA RA /1/, RB /2/, RC /3/, RD /4/, RE /5/, RH /6/, RL /7/, 1 RSP/9/, ME /8/, LFT /9/, RGT /10/, TRU /12/, FAL /11/, CY /13/, 2 ACC /14/, CARRY /15/, ZERO /16/, SIGN /17/, PARITY /18/ DATA REGS/7*0/, REGV/7*-1/, LOCK /7*0/, SP /0/, MAXSP /16/ DATA REGMAP /7,0,1,2,3,4,5,6,6/ C INTBAS IS THE LARGEST INTRINSIC SYMBOL NUMBER DATA INTBAS /23/ DATA VARB /1/, INTR /2/, PROC /3/, LABEL /4/, LITER /6/ C PRSTRASNLITV DATA STHEAD /27,29,30,31,29,12,30,25,23,20,31,33/ DATA OPR /0/, ADR /1/, VLU /2/, DEF /3/, LIT /4/, LIN /5/, *NOP/ 0/,ADD/ 1/,ADC/ 2/,SUB/ 3/,SBC/ 4/,MUL/ 5/,DIV/ 6/,MDF/ 7/, *NEG/ 8/,AND/ 9/,IOR/10/,XOR/11/,NOT/12/,EQL/13/,LSS/14/,GTR/15/, *NEQ/16/,LEQ/17/,GEQ/18/,INX/19/,TRA/20/,TRC/21/,PRO/22/,RET/23/, *STO/24/,STD/25/,XCH/26/,DEL/27/,DAT/28/,LOD/29/,BIF/30/,INC/31/, *CSE/32/,END/33/,ENB/34/,ENP/35/,HAL/36/,RTL/37/,RTR/38/,SFL/39/, *SFR/40/,HIV/41/,LOV/42/,CVA/43/,ORG/44/,DRT/45/,ENA/46/,DIS/47/, *AX1/48/,AX2/49/,AX3/50/ DATA OPCVAL / * 104091, 50127, 50126, 124941, 123726, 100375, 62753, 119832, * 103442, 50767, 83613, 145053, 104095, 67351, 96158, 75741, * 103452, 95260, 74780, 83555, 128844, 128846, 112474, 119839, * 124890, 124879, 144275, 62487, 62239, 95887, 54545, 83534, * 59280, 67151, 67149, 67163, 78615, 120791, 120797, 123991, * 123997, 79137, 95905, 59468, 108370, 63327, 67148, 62750, * 51395, 51396, 51397/ DATA WDSIZE /31/, TWO8 /256/, MAXMEM /2500/ END