seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-22 07:54:25 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity
Files
31738079c43b1cd3eae2815a0dfb36f71505257a
Digital-Research-Source-Code/ASSEMBLY & COMPILE TOOLS/PLM COMPILER/PLM82.FOR
Sepp J Morris 31738079c4 Upload 
Digital Research
2020-11-06 18:50:37 +01:00

6050 lines
180 KiB
Fortran
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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

Reference in New Issue View Git Blame Copy Permalink