C COPYRIGHT 1977 MOSTEK CORPORATION C C C FORTRAN IV CROSS ASSEMBLER FOR THE Z80 C XFOR-80 V1.1 03JUN77 C COPYRIGHT 1977 C MOSTEK CORPORATION C CARROLLTON, TEXAS C C C THE VARIABLES PASSED IN COMMON ARE DEFINED BELOW C C ICRD = LOGICAL INPUT UNIT NUMBER C IPRT = LOGICAL OUTPUT UNIT NUMBER C IPCH = LOGICAL OBJECT MODULE UNIT NUMBER C IMFLE = INTERMEDIATE FILE LOGICAL UNIT NUMBER C MCFLE = MACRO SOURCE FILE LOGICAL UNIT NUMBER C IMREC = RECORD NUMBER FOR INTERMEDIATE FILE C MCREC = RECORD NUMBER FOR MACRO SOURCE FILE C IOLIN = NUMBER OF LINES PER PAGE C IPAGE = OUTPUT PAGE COUNT C LINE = OUTPUT LISTING LINE COUNT C IERRS = TOTAL NUMBER OF ERRORS C IFCOL = FIRST SOURCE COLUMN NUMBER C MCOL = LAST SOURCE COLUMN NUMBER C MLAB = MAXIMUM LABEL LENGTH IN CHARACTERS C MOPC = MAXIMUM OPCODE LENGTH IN CHARACTERS C IBIT = NUMBER OF BITS PER HOST COMPUTER WORD C ICCNT = NUMBER OF CHARACTERS PER HOST COMPUTER WORD C IWORD = NUMBER OF WORDS IN HOST COMPUTER PER LABEL C MXMAC = MAXIMUM NUMBER OF MACROS C MXPAR = MAXIMUM NUMBER OF PARAMETERS PASSED IN MACROS C ITAB = SYMBOL TABLE C ITABV = NUMERIC VALUE OF SYMBOL (USUALLY AN ADDRESS) C INDEX = INDEX INTO THE SYMBOL TABLE C LTAB = LENGTH OF SYMBOL TABLE C NAME = SYMBOL BUFFER C ISSYM = DEFL SYMBOL FLAG C LABCT = SYMBOL CHARACTER COUNT C KWTYP = KEYWORD TYPE C KWVAL = KEYWORD VALUE C KWIND = KEYWORD INDEX C NJMP = INSTRUCTION CLASS C LPAR = LEADING PARENTHESIS FLAG C MLCOL = MAXIMUM SOURCE COLUMNS THAT WILL BE PRINTED C NSPAR = SCAN PARENTHESIS FLAG C MDISK = TABLE OF STARTING RECORD NUMBERS FOR MACROS C MPARC = NUMBER OF PARAMETERS IN A MACRO DEFINITION C MPARP = POINTERS TO BEGINNING AND END OF EACH MACRO PARAMETER C MCNAM = MACRO NAME TABLE C MCALL = MACRO CALL LINE BUFFER C MCNT = MACRO COUNT (TOTAL NUMBER OF MACROS) C MSAVE = TEMPORARY STORAGE USED WHEN NESTING MACROS C MCSET = MACRO NESTING LEVEL NUMBER C MPCNT = MACRO PARAMETER COUNT (TOTAL NUMBER FOR ALL CALLS) C NBIN = STRING BUFFER FOR CONST ROUTINE C ICNT = OUT SUBROUTINE BYTE COUNT C IRLEN = RECORD LENGTH OF OBJECT RECORD C ICKSM = CHECK SUM OF OBJECT RECORD C LODLC = ADDRESS FOR OBJECT RECORD C IOBIN = STORAGE FOR OBJECT BYTES C ISN = INTERNAL LINE COUNT C LISN = OUTPUT LINE COUNT C MSREC = MACRO RECORD NUMBER C IEND = END CARD INDICATOR C LLEN = LENGTH OF BYTES IN ARGUMENT FIELD C IBIN = ARRAY FOR ONE LINE OF OBJECT CODE C IADDR = OUTPUT BUFFER FOR PROGRAM COUNTER AND SYMBOL TALBE C LSOR = FLAG TO INDICATE SOURCE WILL BE LISTED C LSYM = FLAG TO INDICATE THE SYMBOL TABLE WILL BE LISTED C LMAC = FLAG TO INDICATE MACROS WILL BE EXPANDED C LIF = FLAG TO INDICATE WHETHER IF STATEMENTS WILL BE EXPANDED C LOBJ = FLAG TO INDICATE OBJECT MODULE WILL BE PUNCHED C LREF = FLAG TO INDICATE CROSS REFERENCE TABLE WILL BE LISTED C LEVEL = CURRENT MACRO LEVEL NUMBER C LC = LOCATION COUNTER C IPVAL = TEMPORARY STORAGE LOCATION C LEN = LENGTH OF CURRENT INSTRUCTION IN BYTES C MAC = INDICATES A MACRO IS CURRENTLY BEING PROCESSED C IOPVA = NUMERIC VALUE OF CURRENT OPCODE C IARG = FIRST COLUMN OF ARGUMENT FIELD C IERRI = ERROR INDICATORS FOR OUTPUT C ITYPE = INSTRUCTION TYPE NUMBER C IN = CARD IMAGE INPUT BUFFER C IERR = ERROR STATUS INDICATOR C IAST = HOST REPRESENTATION OF AN ASTERISK C IDOLR = HOST REPRESENTATION OF A DOLLAR SIGN C IQUOT = HOST REPRESENTATION OF A QUOTE CHARACTER C ICOLN = HOST REPRESENTATION OF A COLON C ISHRP = HOST REPRESENTATION OF SHARP SIGN C IBLNK = HOST REPRESENTATION OF A BLANK C ICOMM = HOST REPRESENTATION OF A COMMA C ISEMI = HOST REPRESENTATION OF A SEMICOLON C ICTAB = HOST REPRESENTATION OF HORIZONTAL TAB C IPER = HOST REPRESENTATION OF PERIOD C IPLUS = HOST REPRESENTATION OF PLUS CHARACTER C IMIN = HOST REPRESENTATION OF MINUS CHARACTER C IMULT = HOST REPRESENTATION OF AN ASTERISK C IDIV = HOST REPRESENTATION OF A SLASH C IRPAR = HOST REPRESENTATION OF A RIGHT PARENTHESIS C ILPAR = HOST REPRESENTATION OF A LEFT PARENTHESIS C IEQUL = HOST REPRESENTATION OF EQUAL SIGN C IGRAT = HOST REPRESENTATION OF A GREATER THAN CHARACTER C ILESS = HOST REPRESENTATION OF A LESS THAN CHARACTER C IAMP = HOST REPRESENTATION OF AMPERSAND C IVBAR = HOST REPRESENTATION OF VERTICAL BAR C IALPH = ASSEMBLER CHARACTER SET C LTITL - ARRAY FOR TITLE C ICHRA = HOST REPRESENTATION OF CHARACTER A C ICHRB = HOST REPRESENTATION OF CHARACTER B C ICHRC = HOST REPRESENTATION OF CHARACTER C C ICHRD = HOST REPRESENTATION OF CHARACTER D C ICHRE = HOST REPRESENTATION OF CHARACTER E C ICHRF = HOST REPRESENTATION OF CHARACTER F C ICHRH = HOST REPRESENTATION OF CHARACTER H C ICHRK = HOST REPRESENTATION OF CHARACTER K C ICHRL = HOST REPRESENTATION OF CHARACTER L C ICHRM = HOST REPRESENTATION OF CHARACTER M C ICHRN = HOST REPRESENTATION OF CHARACTER N C ICHRO = HOST REPRESENTATION OF CHARACTER O C ICHRQ = HOST REPRESENTATION OF CHARACTER Q C ICHRR = HOST REPRESENTATION OF CHARACTER R C ICHRS = HOST REPRESENTATION OF CHARACTER S C ICHRT = HOST REPRESENTATION OF CHARACTER T C ICHRU = HOST REPRESENTATION OF CHARACTER U C ICHRV = HOST REPRESENTATION OF CHARACTER V C ICHRY = HOST REPRESENTATION OF CHARACTER Y C MXREF = SIZE OF CROSS REFERENCE ARRAY C IXTAB = CROSS REFERENCE ARRAY C IXT = CROSS REFERENCE DISK RECORD C IXPNT = POINTER INTO CROSS REFERENCE TABLE C IXCNT = NUMBER OF CROSS REFERENCE PAGES C IXPAG = MAXIMUM NUMBER OF CROSS REFERENCE PAGES C IPASS = PASS INDICATOR C MCORE = BUFFER USED TO WRITE CROSS REFERENCE DISK FILE C C C C THE MAIN ROUTINE CALLS THE MAJOR SUBROUTINES C C REAL LC,LODLC,IPVAL,ITABV(200) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) C C THE FOLLOWING DEFINE FILE STATEMENTS DEFINE THE INTERMEDIATE C FILE AND THE MACRO SOURCE FILE USED BY THIS ASSEMBLER. THESE ARE C STANDARD IBM STATEMENTS. THE INTERMEDIATE FILE DEFINED (SYMBOLIC C FILE NUMBER 2) CONSISTS OF 2000 94-WORD RECORDS. U INDICATES A C BINARY FILE. THE NAME IMREC IS THE RECORD INDEX. THE MACRO C SOURCE FILE IS DEFINED IN A SIMILAR MANNER. C VARIOUS COMPUTERS DEFINE FILES IN DIFFERENT WAYS. THIS FILE C MIGHT HAVE TO BE DEFINED DIFFERENTLY ON YOUR COMPUTER. C ALSO NOTE THAT THE INTERMEDIATE FILE COULD BE A TAPE FILE. C DEFINE FILE 2(2000,93,U,IMREC) DEFINE FILE 4(200,128,U,MCREC) CALL INIT CALL PASS1 CALL PASS2 IF(LSYM+LREF) 400,400,100 100 WRITE(IPRT,1000) (LTITL(I),I=1,28),IPAGE 1000 FORMAT(34H1 MOSTEK XFOR-80 CROSS ASSEMBLER, 1 1X,28A1,5H PAGE,I4,//) IF(LREF) 200,200,250 200 WRITE(IPRT,1010) 1010 FORMAT(32X,12HSYMBOL TABLE,/) LINE = 4 GO TO 300 250 WRITE(IPRT,1011) 1011 FORMAT(30X,15HCROSS REFERENCE,//, 1 15H LABEL VALUE,7X,9HREFERENCE,/) LINE = 6 300 CALL SYMTA 400 WRITE(IPRT,1001) 1001 FORMAT(1H1) STOP END SUBROUTINE INIT C C THIS SUBROUTINE INITIALIZES THE C VARIABLES USED BY THE ASSEMBLER C REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION NALPH(62) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) C C SOME COMPUTERS DO NOT ACCEPT THE FULL ASCII CHARACTER SET. C THEREFORE SOME OF THE CHARACTERS DEFINED BELOW MAY BE ILLEGAL C ON YOUR MACHINE. IF THIS IS THE CASE, THE ILLEGAL CHARACTERS C SHOULD BE REPLACED BY VALID CHARACTERS. IF THE ILLEGAL CHARACTERS C ARE NOT USED IN THE ASSEMBLER LANGUAGE, REPLACE THEM WITH BLANKS. C IF THE ILLEGAL CHARACTERS ARE USED IN THE ASSEMBLER LANGUAGE, C REPLACE THEM WITH ANY OTHER VALID CHARACTERS. C THE ILLEGAL CHARACTERS MUST BE CHANGED IN THE FOLLOWING TWO DATA C ARRAYS. C DATA NALPH( 1),NALPH( 2),NALPH( 3),NALPH( 4) /1H0,1H1,1H2,1H3/ DATA NALPH( 5),NALPH( 6),NALPH( 7),NALPH( 8) /1H4,1H5,1H6,1H7/ DATA NALPH( 9),NALPH(10),NALPH(11),NALPH(12) /1H8,1H9,1HA,1HB/ DATA NALPH(13),NALPH(14),NALPH(15),NALPH(16) /1HC,1HD,1HE,1HF/ DATA NALPH(17),NALPH(18),NALPH(19),NALPH(20) /1HG,1HH,1HI,1HJ/ DATA NALPH(21),NALPH(22),NALPH(23),NALPH(24) /1HK,1HL,1HM,1HN/ DATA NALPH(25),NALPH(26),NALPH(27),NALPH(28) /1HO,1HP,1HQ,1HR/ DATA NALPH(29),NALPH(30),NALPH(31),NALPH(32) /1HS,1HT,1HU,1HV/ DATA NALPH(33),NALPH(34),NALPH(35),NALPH(36) /1HW,1HX,1HY,1HZ/ DATA NALPH(37),NALPH(38),NALPH(39),NALPH(40) /1H!,1H%,1H?,1H@/ DATA NALPH(41),NALPH(42),NALPH(43),NALPH(44) /1H_,1H ,1H",1H#/ DATA NALPH(45),NALPH(46),NALPH(47),NALPH(48) /1H$,1H&,1H',1H(/ DATA NALPH(49),NALPH(50),NALPH(51),NALPH(52) /1H),1H*,1H+,1H,/ DATA NALPH(53),NALPH(54),NALPH(55),NALPH(56) /1H-,1H.,1H/,1H:/ DATA NALPH(57),NALPH(58),NALPH(59),NALPH(60) /1H;,1H<,1H=,1H>/ DATA NALPH(61),NALPH(62) /1H^,1H]/ DATA NCHRA,NCHRB,NCHRC,NCHRD,NCHRE /1HA,1HB,1HC,1HD,1HE/ DATA NCHRF,NCHRH,NCHRK,NCHRL,NCHRM /1HF,1HH,1HK,1HL,1HM/ DATA NCHRN,NCHRO,NCHRQ,NCHRS,NCHRT /1HN,1HO,1HQ,1HS,1HT/ DATA NCHRU,NCHRV,NCHRY /1HU,1HV,1HY/ DATA NBLNK,NQUOT,NPLUS,NMIN,NGRAT /1H ,1H',1H+,1H-,1H>/ DATA NLESS,NDOLR,NCOMM,NAST,NSEMI /1H<,1H$,1H,,1H*,1H;/ DATA NCOLN,NSHRP,NCTAB,NPER,NAMP /1H:,1H#,1H ,1H.,1H&/ DATA NMULT,NDIV,NLPAR,NRPAR,NEQUL /1H*,1H/,1H(,1H),1H=/ DATA NVBAR,NRSLA /1H^,1H]/ C C DEFINE OBJECT,INPUT,OUTPUT,INTERMEDIATE AND MACRO FILES C IPCH = 3 ICRD = 1 IPRT = 6 IMFLE = 2 MCFLE = 4 C C TO INCREASE THE SIZE OF THE SYMBOL TABLE AND THUS THE C NUMBER AND LENGTH OF THE SYMBOLS USED BY THE ASSEMBLER C THE USER MUST CHANGE CERTAIN VARIABLES. THE VARIABLES C THAT MUST BE CHANGED DEPEND ON THE NUMBER OF BITS C PER WORD FOR YOUR COMPUTER, THE NUMBER OF CHARACTERS C USED TO DEFINE A SYMBOL, AND THE NUMBER OF SYMBOLS IN THE C SYMBOL TABLE. THE VARIABLES THAT DEFINE THESE C CHARACTERISTICS ARE - IBIT,MLAB,ICCNT,IWORD,LTAB. C C IBIT = NUMBER OF BITS PER HOST COMPUTER WORD (SET BY USER) C MLAB = MAXIMUM LABEL LENGTH IN CHARACTERS (SET BY USER) C ICCNT = NUMBER OF CHARACTERS PER HOST COMPUTER WORD (CALCULATED) C IWORD = NUMBER OF COMPUTER WORDS PER LABEL (CALCULATED) C LTAB = LENGTH OF THE SYMBOL TABLE (SET BY USER) C THUS THE FOLLOWING VARIABLES MUST BE CHANGED OR DIMENSIONED C AS FOLLOWS TO CHANGE THE SIZE OF THE SYMBOL TABLE C TO CHANGE THE SIZE OF A SYMBOL OR THE SYMBOL TABLE C C LTAB C ITAB(IWORD,LTAB) C ITABV(LTAB) C NAME(IWORD) C MCNAM(IWORD,MXMAC) C C TO INCREASE THE TOTAL NUMBER OF PARAMETERS THAT MAY BE C USED AMONG ALL NESTED MACROS CHANGE THE FOLLOWING VARIABLES C C MXPAR C C TO INCREASE THE NUMBER OF MACROS THAT MAY BE DEFINED C THE USER MUST CHANGE CERTAIN VARIABLES. THESE VARIABLES C ARE AS FOLLOWS C C MXMAC C MDISK(MXMAC) C MPARC(MXMAC) C MCNAM(IWORD,MXMAC) C MPARP(2,MXPAR) C TO INCREASE PAGE SIZE OF CROSS REFERENCE TABLE OR TOTAL C NUMBER OF PAGES PRODUCED OR TO NOT USE DISK TO STORE C REFERENCES, THE FOLLOWING VARIABLES MUST BE CHANGED. C C MXREF = MAXIMUM PAGE SIZE OF CROSS REFERENCE TABLE. THE C NUMBER OF REFERENCES ON A PAGE IS (MXREF/2). MXREF SHOULD BE C GREATER THAN OR EQUAL TO (2*MLAB) AND DIVISIBLE BY 128. C IXTAB = ARRAY TO ACCUMULATE CROSS REFERENCES C IXPAG = TOTAL NUMBER OF PAGES OF SIZE MXREF THAT WILL BE C PRODUCED BEFORE ACCUMULATING REFERENCES STOPS. IF C IXPAG = 0, THEN THE DISK FILE WILL NOT BE USED AND REFERENCES C WILL ONLY BE ACCUMULATED IN MEMORY UNTIL FULL. C C TO INCREASE CROSS REFERENCE PAGE SIZE THE FOLLOWING SHOULD BE C CHANGED. C C MXREF C IXTAB(MXREF) C C IBIT = 16 MLAB = 6 ICCNT = IBIT/8 IWORD = 1+(MLAB-1)/ICCNT LTAB = 200 IFCOL = 1 MCOL = 72 MOPC = 5 MXMAC = 50 MXPAR = 60 NSPAR = 0 LC = 0 LODLC = -1. MSREC = 1 ISN = 1 LISN = 0 IOLIN = 56 C TO CHANGE OUTPUT LINE SIZE SET MLCOL TO (OUTPUT WIDTH-24) C ILCOL SHOULD NOT BE SET GREATER THAN 80. MLCOL = 48 LINE = IOLIN IERRS = 0 IPAGE = 1 LSOR = 1 LSYM = 1 LMAC = 0 LIF = 0 LOBJ = 1 LREF = 0 IXPAG = 25 MXREF = 1024 IXT = 1 IXPNT = 0 IXCNT = 0 C INITIALIZE THE SYMBOL TABLE TO ZEROS DO 20 LL=1,LTAB DO 30 K=1,IWORD ITAB(K,LL) = 0 30 CONTINUE ITABV(LL) = 0. 20 CONTINUE C INITIALIZE THE CHARACTER VARIABLES DO 40 K=1,62 IALPH(K) = NALPH(K) 40 CONTINUE C C THE CHARACTERS LISTED BELOW ARE CHARACTERS USED INTERNALLY BY C THE ASSEMBLER FOR ERROR CODES AND SYNTAX. C ICHRA = NCHRA ICHRB = NCHRB ICHRC = NCHRC ICHRD = NCHRD ICHRE = NCHRE ICHRF = NCHRF ICHRH = NCHRH ICHRK = NCHRK ICHRL = NCHRL ICHRM = NCHRM ICHRN = NCHRN ICHRO = NCHRO ICHRQ = NCHRQ ICHRS = NCHRS ICHRT = NCHRT ICHRU = NCHRU ICHRV = NCHRV ICHRY = NCHRY IAST = NAST IDOLR = NDOLR IQUOT = NQUOT ICOLN = NCOLN ISHRP = NSHRP IBLNK = NBLNK ICOMM = NCOMM ISEMI = NSEMI ICTAB = NCTAB IPER = NPER IPLUS = NPLUS IMIN = NMIN IMULT = NMULT IDIV = NDIV IRPAR = NRPAR ILPAR = NLPAR IRSLA = NRSLA IEQUL = NEQUL IGRAT = NGRAT ILESS = NLESS IAMP = NAMP IVBAR = NVBAR DO 200 LL=1,50 LTITL(LL) = IBLNK 200 CONTINUE RETURN END SUBROUTINE INOUT(ICTL) C C C THIS ROUTINE PERFORMS ALL I/O FOR THE PROGRAM EXCEPT C FOR THE FINAL OUTPUT LISTING. THESE STATEMENTS MAY C HAVE TO CHANGE ON SOME MACHINES PARTICULARILY FOR DISK C I/O. TWO STATEMENTS ARE SHOWN FOR EACH DISK I/O C OPERATION. A STANDARD READ OR WRITE AS USED BY IBM, DEC C AND SOME OTHERS, AND A CALL TO A SYSTEM I/O ROUTINE C AS USED BY H.P. AND SOME OTHERS.(FOR INFORMATIVE PURPOSES) C THE RECORD NUMBER FOR RANDOM ACCESS I/O IS PASSED INTO THE C ROUTINE VIA COMMON. C C REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION NAMEI(3),NAMEM(3),MCBUF(80),IMBUF(93) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE(LC,IMBUF(1)) EQUIVALENCE (NBIN(1),MCBUF(1)) DATA NAMEI(1),NAMEI(2),NAMEI(3) /2HIM,2HFL,2HE / DATA NAMEM(1),NAMEM(2),NAMEM(3) /2HMC,2HFL,2HE / C C *ENTRY PARAMETERS C ICTL - I/O CONTROL WORD C 1 = READ SOURCE C 2 = READ INTERMEDIATE RECORD C 3 = READ MACRO RECORD C 4 = READ CROSS REFERENCE RECORD C 5 = WRITE INTERMEDIATE RECORD C 6 = WRITE MACRO RECORD C 7 = WRITE CROSS REFERENCE RECORD C GO TO(100,200,300,400,500,600,700),ICTL C C READ SOURCE 100 READ(ICRD,1000) IN 1000 FORMAT(80A1) RETURN C READ INTERMEDIATE FILE 200 READ(IMFLE'IMREC) IMBUF C CALL EXEC(14,1091,IMBUF,93,NAMEI,IMREC) RETURN C READ MACRO FILE 300 READ(MCFLE'MCREC) MCBUF C CALL EXEC(14,1091,MCBUF,80,NAMEM,MCREC) RETURN C READ CROSS REFERENCE FILE 400 READ(MCFLE'MCREC) MCORE C CALL EXEC(14,1091,MCORE,128,NAMEM,MCREC) RETURN C WRITE INTERMEDIATE FILE 500 WRITE(IMFLE'IMREC) IMBUF C CALL EXEC(15,1091,IMBUF,93,NAMEI,IMREC) RETURN C WRITE MACRO FILE 600 WRITE(MCFLE'MCREC) MCBUF C CALL EXEC(15,1091,MCBUF,80,NAMEM,MCREC) RETURN C WRITE CROSS REFERENCE FILE 700 WRITE(MCFLE'MCREC) (IXTAB(J),J=1,128) C CALL EXEC(15,1091,IXTAB,128,NAMEM,MCREC) RETURN END SUBROUTINE PASS1 C C C THIS SUBROUTINE EXECUTES THE PSEUDO-OPS THAT NEED TO BE EXECUTED C DURING PASS 1, PROCESSES SYMBOLS IN THE LABEL FIELD, STORES C INFORMATION IN THE INTERMEDIATE FILE WHICH IS USED DURING PASS 2, C STORES THE MACRO DEFINITIONS ON THE MACRO SOURCE FILE, AND C INCREMENTS THE LOCATION COUNTER FOR EACH INSTRUCTION MAKING ROOM C FOR THE RESULTING OBJECT CODE. C C REAL IVAL,LENBS REAL LC,LODLC,IPVAL,ITABV(200) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) DATA LISTS /1HI/ C C *ENTRY PARAMETERS C VARIABLES IN COMMON INITIALIZED IN INIT C C *EXIT PARAMETERS C SOURCE LINE ALONG WITH PROGRAM COUNTER,INSTRUCTION LENGTH C INSTRUCTION TYPE, ETC. WRITTEN TO INTERMEDIATE FILE. C IPASS = 1 LISN = 1 MAC = 1 IEND = 0 IMREC = 1 MCREC = 1 LEVEL = 0 IERR = 1 C INITIALIZE IF STATEMENT NESTING LEVEL NUMBER IFSET = 0 IFON = 0 C INITIALIZE CURRENT NESTING LEVEL MCSET = 0 C INITIALIZE IF STATEMENT FLAG IFCTL = 0 C INITIALIZE CURRENT LEVEL NUMBER LEVEL = 0 C INITIALIZE TOTAL MACRO COUNT MCNT = 0 C INITIALIZE TOTAL MACRO PARAMETER COUNT MPCNT = 0 IPVAL = 0 C INITIALIZE NUMBER OF PARAMETERS FOR CURRENT MACRO NOPAR = 0 C INITIALIZE ERROR INDICATORS 100 IERRI(1) = IBLNK IERRI(2) = IBLNK IERRI(3) = IBLNK IERRI(4) = 0 IOPVA = 0 LEN = 0 INDEX = 0 ITYPE = 0 C INITIALIZE INDEX INTO SYMBOL TABLE INDET = 0 C INITIALIZE CURRENT COLUMN NUMBER ICOL = IFCOL C INITIALIZE BYTE COUNT FOR DEFS DIRECTIVE LENBS = 0 IF(MAC-1) 110,110,120 C READ SOURCE FROM INPUT DEVICE 110 CALL INOUT(1) GO TO 130 C READ SOURCE FROM MACRO DEFINITION 120 CALL MCREF LISN=LISN-1 IF(IERRI(4)-1) 125,135,125 125 IMERR = IERR C CHECK FOR A COMMENT OR ASSEMBLER COMMAND 130 IF (IN(ICOL)-IAST) 132,135,132 132 IF(IN(ICOL)-ISEMI) 136,135,136 135 ITYPE = -1 IF (IFCTL-2) 805,195,805 C CHECK FOR A LABEL 136 IF(IN(ICOL)-IBLNK) 137,160,137 137 IF(IN(ICOL)-ICTAB) 138,160,138 138 IF(INDET) 139,139,910 C GET AND PROCESS LABEL 139 CALL LABEL(ICOL,IVAL,0) IF (IFCTL-2) 140,160,140 C IF NEXT CHARACTER IS NOT BLANK OR COLON, LABEL IS IN ERROR 140 IF (IN(ICOL)-IBLNK) 141,145,141 141 IF (IN(ICOL)-ICOLN) 142,144,142 142 IF (IN(ICOL)-ISEMI) 143,145,143 143 IF (IN(ICOL)-ICTAB) 900,145,900 144 ICOL=ICOL+1 145 GO TO (970,146,900,925),IERR 146 DO 147 I=1,IWORD ITAB(I,INDEX) = NAME(I) 147 CONTINUE 150 ITABV(INDEX) = LC 155 INDET = INDEX CALL XREFT(0,0) LDUP = IERR IERR = IMERR C GET OPCODE FIELD. 160 CALL OPCOD(ICOL,ICHK) 180 IF(IFCTL-2) 185,190,185 185 GO TO(200,910,910,135,187,138),IERR C NO OPCODE ON LINE, CHECK IF LABEL PRESENT 187 IERR = 2 IF(INDET) 800,910,800 C CHECK IF THIS IS AN IF LOOP AND THESE LINE ARE TO BE SKIPPED C CHECK FOR ENDIF DIRECTIVE 190 IF(ICHK-1015) 192,450,192 192 IF(ICHK-1006) 193,360,193 193 IF(ICHK-1014) 195,194,195 194 IFSET = IFSET+1 C CHECK IF SKIPPED IF LINES ARE TO BE LISTED 195 IF(LIF) 196,100,196 196 LEN = 0 ITYPE = -1 GO TO 805 C C IF AN ASSEMBLER DIRECTIVE OR A MACRO REFERENCE WAS THE OPERATION C PROCESS IT NOW IF NECESSARY, OTHERWISE PROCESS IT IT PASS 2 C 200 ICOL = IARG IF(ITYPE-2) 300,600,250 250 CALL CODEZ(ICOL) GO TO 805 300 GO TO(310,320,330,340,350,360,370,800,390, 1 400,410,420,430,440,450,460,470,480),IOPVA C ***** PROCESS THE ORG DIRECTIVE 310 CALL SCAN(ICOL,IVAL) 311 GO TO(312,950,940,312,930),IERR 312 LC = IVAL C SET VALUE IF ORG HAS A LABEL IF(IERRI(1)-ICHRD) 315,800,315 315 IF(INDET) 800,800,316 316 ITABV(INDET) = LC GO TO 800 C ***** PROCESS THE EQU DIRECTIVE 320 IF(IERRI(1)-ICHRD) 321,800,321 321 IF(INDET) 960,960,322 322 IOPVA = -INDET CALL SCAN(ICOL,IVAL) GO TO(324,323,323,324,323),IERR C SET VALUE TO ZERO IF THERE IS AN ERROR 323 IPVAL = 0 ITABV(INDET) = 0 GO TO 311 324 IPVAL = IVAL ITABV(INDET) = IVAL GO TO 800 C ***** PROCESS THE DEFB DIRECTIVE 330 LEN = 1 GO TO 800 C ***** PROCESS THE DEFS DIRECTIVE 340 CALL SCAN(ICOL,IVAL) GO TO (342,950,940,342,930),IERR 342 LENBS = IVAL GO TO 800 C **** PROCESS THE DEFW DIRECTIVE 350 LEN = 2 GO TO 800 C ***** PROCESS THE END DIRECTIVE 360 IEND = 1 GO TO 800 C ***** PROCESS THE EJEC DIRECTIVE 370 GO TO 800 C ***** PROCESS THE LIST DIRECTIVE 390 LSET = 1 392 IF(IARG-MCOL) 393,393,800 393 ICOL = IARG 394 IF(IN(ICOL)-LISTS) 398,397,398 397 LIF = LSET 398 ICOL1 = ICOL+1 ICOL = ICOL1+1 IF(IN(ICOL1)-ICOMM) 800,394,800 C ***** PROCESS NLIST DIRECTIVE 400 LSET = 0 GO TO 392 C ***** PROCESS THE SPAC DIRECTIVE 410 GO TO 800 C ***** PROCESS THE DEFL DIRECTIVE 420 IF(INDET) 960,960,421 421 IOPVA = -INDET IF(IERRI(1)-IBLNK) 422,424,422 422 IF(ISSYM) 800,800,423 423 IERRI(1) = IBLNK IERRI(4) = 0 IERRS = IERRS-1 424 CALL SCAN(ICOL,IVAL) GO TO(425,950,940,425,930),IERR 425 IPVAL = IVAL ITABV(INDET) = IVAL+100000. GO TO 800 C ***** PROCESS THE TITLE DIRECTIVE 430 GO TO 800 C ***** PROCESS THE IF DIRECTIVE 440 CALL SCAN(ICOL,IVAL) GO TO (442,950,940,442,930),IERR 442 IF(IVAL) 444,443,444 443 IFCTL = 2 IFON = IFSET 444 IFSET = IFSET+1 GO TO 800 C ***** PROCESS THE ENDIF DIRECTIVE 450 IF(IFSET-1) 912,452,454 452 IFCTL = 1 454 IFSET = IFSET-1 IF(IFSET-IFON) 456,455,456 455 IFCTL = 1 456 IF(IFCTL-2) 457,195,457 457 IFON = 0 GO TO 800 C ***** PROCESS THE MACR DIRECTIVE 460 IF(MAC-1) 4605,4605,912 4605 IF(MCNT-MXMAC) 461,925,925 461 IF(INDET) 960,960,4612 4612 IERR = LDUP IXPNT = IXPNT-2 IF(MCNT) 4614,4625,4614 4614 DO 462 N=1,MCNT C DO 4616 LL=1,IWORD IF(ITAB(LL,INDET)-MCNAM(LL,N)) 462,4616,462 4616 CONTINUE IERRI(1) = ICHRD IF(IERR-2) 990,4618,990 4618 ITAB(1,INDET) = 0 GO TO 990 462 CONTINUE 4625 MCNT = MCNT+1 DO 4630 LL=1,IWORD MCNAM(LL,MCNT) = ITAB(LL,INDET) 4630 CONTINUE IF(IERR-2) 4640,4650,4660 4640 IERRI(1) = IBLNK IERRI(4) = 0 IERRS = IERRS-1 GO TO 4660 4650 ITAB(1,INDET) = 0 4660 CALL MCDEF IF(IEND) 4670,100,4670 4670 ISN = ISN-1 ITYPE = 1 GO TO 800 C ***** PROCESS THE ENDM DIRECTIVE 470 IF(MCSET) 912,912,472 472 MCREC = MSAVE(1,MCSET) MCSET = MCSET-1 IF(MCSET) 476,476,474 474 NOPAR = MSAVE(2,MCSET) MPCNT = MPCNT-NOPAR GO TO 478 476 MAC = 1 MPCNT = 0 478 IF(IERRI(4)) 100,100,805 C ***** PROCESS THE DEFM DIRECTIVE 480 CALL CONST(ICOL,IVAL) LEN = LLEN GO TO 805 C C PROCESS A MACRO REFERENCE CALL. MACRO MUST BE EXPANDED C IOPVA INDICATES WHICH MACRO IS BEING CALLED. C 600 IF(MCSET-3) 602,915,915 602 IF(MCSET) 604,604,603 603 MPCNT = MPCNT+NOPAR 604 LEVEL = LEVEL+1 MCSET = MCSET+1 MSAVE(1,MCSET) = MCREC MCREC = MDISK(IOPVA) NOPAR = MPARC(IOPVA) MSAVE(2,MCSET) = NOPAR C SET UP PARAMETER TABLE 605 DO 610 LL=1,80 MCALL(LL,MCSET) = IN(LL) 610 CONTINUE C SET SYSTEM LEVEL NUMBER FOR #$YM SYMBOL ID = 4096 L = LEVEL DO 612 LL=1,4 N = 1+L/ID I = 81+LL MCALL(I,MCSET) = IALPH(N) L = L-(N-1)*ID ID = ID/16 612 CONTINUE MCALL(81,MCSET) = IBLNK LL = MPCNT+1 MPARP(1,LL) = 82 MPARP(2,LL) = 85 IF(NOPAR-1) 660,660,614 614 DO 620 MM=2,NOPAR LL = LL+1 IF(LL-MXPAR) 616,616,925 616 MPARP(1,LL) = 81 MPARP(2,LL) = 81 620 CONTINUE C SCAN FOR PARAMETERS FROM MACRO REFERENCE CALL ICOL = IARG L = MPCNT+2 622 ISTA = ICOL IF(ISTA-MCOL) 624,660,660 624 NCHAR = IN(ICOL) IF(NCHAR-IBLNK) 626,644,626 626 IF(NCHAR-ISEMI) 628,644,628 628 IF(NCHAR-ICTAB) 630,644,630 630 IF(NCHAR-ICOMM) 632,644,632 632 IF(NCHAR-IQUOT) 634,636,634 634 ICOL = ICOL+1 IF(ICOL-MCOL) 624,624,644 C SCAN OVER QUOTE STRING 636 ICOL = ICOL+1 IF(IN(ICOL)-IQUOT) 642,638,642 638 ICOL1 = ICOL+1 IF(IN(ICOL1)-IQUOT) 634,640,634 640 ICOL = ICOL1 642 IF(ICOL-MCOL) 636,644,644 644 IF(ISTA-ICOL) 646,652,646 C CHECK FOR OUTER QUOTES ON PARAMETER 646 IF(IN(ISTA)-IQUOT) 650,648,650 648 MPARP(1,L) = ISTA+1 MPARP(2,L) = ICOL-2 GO TO 652 650 MPARP(1,L) = ISTA MPARP(2,L) = ICOL-1 C CHECK FOR END OF PARAMETER LIST 652 IF(IN(ICOL)-ICOMM) 660,654,660 654 ICOL = ICOL+1 L = L+1 IF(L-(NOPAR+MPCNT)) 622,622,660 660 GO TO 800 C C CHECK FOR AN EXPRESSION ERROR 800 IF(IERR-4) 805,980,805 805 IMREC = ISN ISN = ISN+1 C WRITE RECORD TO INTERMEDIATE FILE CALL INOUT(5) IF(ITYPE-2) 815,810,815 810 MAC = 2 815 IVAL = LEN LISN = LISN+1 LC = LC+IVAL+LENBS IF(LC-65536.) 830,820,820 820 LC = LC-65536. C CHECK FOR END CARD OR END OF FILE 830 IF(IEND) 840,100,840 840 RETURN C SET ERROR INDICATORS INTO THE OUTPUT VARIABLES C LABEL ERROR 900 IERRI(1) = ICHRL C INCREMENT PC BY 3 TO PROVIDE FOR A PATCH 905 LEN = 4 GO TO 990 C OPCODE ERROR 910 LEN = 4 912 IERRI(2) = ICHRO GO TO 990 C MACRO NESTING ERROR 915 IERRI(2) = ICHRN GO TO 990 C TABLE OVERFLOW ERROR 925 IERRI(2) = ICHRT GO TO 990 C SYNTAX ERROR - ILLEGAL EXPRESSION 930 IERRI(2) = ICHRS GO TO 990 C ARGUMENT ERROR - UNDEFINED SYMBOL 940 IERRI(2) = ICHRU GO TO 990 C ARGUMENT ERROR 950 IERRI(2) = ICHRA GO TO 990 C MISSING LABEL ON EQU OR DEFL OR MACR DIRECTIVE 960 IERRI(1) = ICHRM GO TO 990 C DUPLICATE LABEL ERROR 970 IERRI(1) = ICHRD IERRS = IERRS+1 IERRI(4) = 1 GO TO 155 C FORMAT ERROR 980 IERRI(2) = ICHRF 990 IERRS = IERRS+1 IERRI(4) = 1 IERR = 1 GO TO 800 END SUBROUTINE PASS2 C C C THIS ROUTINE PROCESSES INSTRUCTION ARGUMENTS, GENERATES OBJECT C CODE, EXECUTES ALL PSEUDO-OPS NOT EXECUTED IN PASS 1, AND C GENERATES THE OUTPUT LISTING. C C REAL IVAL,IVAL2 REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION LCTL(6),LISTS(6) C COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE(LCTL(1),LSOR) DATA LISTS(1),LISTS(2),LISTS(3) /1HS,1HT,1HM/ DATA LISTS(4),LISTS(5),LISTS(6) /1HI,1HO,1HX/ C C *ENTRY PARAMETERS C INFORMATION FROM INTERMEDIATE FILE C C *EXIT PARAMETERS C OUTPUT LISTING AND OBJECT MODULE PRODUCED C IPASS = 2 ISN = 1 LISN = 0 IEND = 0 LINE = IOLIN 1 IMREC = ISN ISN = ISN+1 C C READ NEXT RECORD FROM INTERMEDIATE FILE CALL INOUT(2) IBIN(1) = IOPVA IBIN(2) = 0 IBIN(3) = 0 IBIN(4) = 0 MODE = 1 IF(ITYPE) 450,800,20 20 IF(ITYPE-2) 500,800,100 C C PROCESS OPCODES 100 CALL CODEZ(IARG) GO TO(800,910,900,800,930,960,970,940),IERR C C CHECK IF ASSEMBLER COMMAND 450 ICOL = IFCOL IARG = MCOL IF(IN(ICOL)-IAST) 800,452,800 452 ICOL = ICOL+1 NCHAR = IN(ICOL) C CHECK IF EJECT IF(NCHAR-ICHRE) 454,570,454 C SCAN TO ARGUMENT 454 ICOL = ICOL+1 IF(IN(ICOL)-IBLNK) 454,456,454 456 ICOL = ICOL+1 IF(ICOL-MCOL) 458,458,476 458 IF(IN(ICOL)-IBLNK) 460,456,460 460 IARG = ICOL-1 IF(NCHAR-ICHRH) 462,630,462 462 LSET = 1 IF(IN(ICOL)-ICHRO) 910,464,910 464 ICOL = ICOL+1 IF(IN(ICOL)-ICHRF) 468,466,468 466 LSET = 0 C CHECK FOR MACRO 468 IF(NCHAR-ICHRM) 472,470,472 470 LMAC = LSET GO TO 800 C CHECK FOR LIST 472 IF(NCHAR-ICHRL) 910,474,910 474 LSOR = LSET GO TO 800 C CHECK FOR HEADING 476 IF(NCHAR-ICHRH) 910,630,910 C C PROCESS ASSEMBLER DIRECTIVES (TYPE 1) C 500 ITYPE = -1 IF(IOPVA) 520,505,505 505 GO TO(510,520,530,540,550,560,570,800,590,600,610,620, 1 630,640,650,660,670,680),IOPVA C ***** PROCESS ORG 510 GO TO 690 C ***** PROCESS EQU DIRECTIVE 520 CALL SCAN(IARG,IVAL) INDEX = -IOPVA IF(INDEX) 805,805,525 525 ITABV(INDEX) = IPVAL IOPVA = 100 GO TO 805 C ***** PROCESS DEFB DIRECTIVE 530 IBIN(1) = 0 ITYPE = 1 IF(IARG-MCOL) 531,531,910 531 CALL SCAN(IARG,IVAL) GO TO(532,910,900,532,930),IERR 532 IF(IVAL-256.) 535,533,533 533 IF(IVAL-65280.) 940,534,534 534 IVAL = IVAL-65280. 535 IBIN(1) = IVAL GO TO 800 C ***** PROCESS DEFS DIRECTIVE 540 ITYPE = 1 GO TO 690 C ***** PROCESS DEFW DIRECTIVE 550 IBIN(1) = 0 ITYPE = 1 IF(IARG-MCOL) 551,551,910 551 CALL SCAN(IARG,IVAL) GO TO(552,910,900,552,930),IERR 552 IBIN(2) = IVAL/256. IVAL2 = IBIN(2) IBIN(1) = IVAL-IVAL2*256. GO TO 800 C ***** PROCESS END DIRECTIVE 560 IPVAL = 0. IEND = 1 ITYPE = 1 IF(IARG-MCOL) 561,561,800 561 CALL SCAN(IARG,IVAL) GO TO(562,910,900,562,930),IERR 562 IPVAL = IVAL GO TO 800 C ***** PROCESS EJEC DIRECTIVE 570 MODE = 4 IF(LSOR) 575,800,575 575 LINE = 100 GO TO 800 C ***** PROCESS LIST DIRECTIVE 590 LSET = 1 592 IF(IARG-MCOL) 594,594,910 594 DO 595 LL=1,6 IF(IN(IARG)-LISTS(LL)) 595,596,595 595 CONTINUE GO TO 910 596 LCTL(LL) = LSET ICOL1 = IARG+1 IARG = ICOL1+1 IF(IN(ICOL1)-IBLNK) 597,800,597 597 IF(IN(ICOL1)-ICOMM) 598,594,598 598 IF(IN(ICOL1)-ICTAB) 910,800,910 C ***** PROCESS NLIST DIRECTIVE 600 LSET = 0 GO TO 592 C ***** PROCESS SPAC DIRECTIVE 610 CALL SCAN(IARG,IVAL) GO TO (615,910,900,615,930),IERR 615 IARG = IVAL MODE = 3 GO TO 800 C ***** PROCESS DEFL DIRECTIVE 620 GO TO 520 C ***** PROCESS TITLE DIRECTIVE 630 N = 1 IF(IARG-MCOL) 631,631,635 631 IARG = IARG+1 ICOL = IARG+49 DO 633 J=IARG,ICOL IF(J-MCOL) 632,632,634 632 LTITL(N) = IN(J) N = N+1 633 CONTINUE 634 IF(N-50) 635,635,638 635 DO 636 J=N,50 LTITL(J) = IBLNK 636 CONTINUE C CHECK IF *HEADING COMMAND 638 IF(IOPVA-13) 570,800,570 C ***** PROCESS IF DIRECTIVE 640 GO TO 690 C ***** PROCESS ENDIF DIRECTIVE 650 GO TO 800 C ***** PROCESS MACR DIRECTIVE 660 GO TO 800 C ***** PROCESS ENDM DIRECTIVE 670 GO TO 800 C ***** PROCESS DEFM DIRECTIVE 680 IF(LEN) 910,910,681 681 ITYPE = 1 CALL CONST(IARG,IVAL) IF(IERR-1) 683,683,682 682 IERRI(2) = ICHRA IERRI(4) = 1 IERRS = IERRS+1 683 DO 684 LL=1,4 IBIN(LL) = NBIN(LL) IF(LL-LLEN) 684,685,685 684 CONTINUE 685 CALL LOUT(MODE) LL = 0 686 LLEN = 0 687 LLEN = LLEN+1 LL = LL+1 IBIN(LLEN) = NBIN(LL) IF(LL-LEN) 688,689,689 688 IF(LLEN-4) 687,689,689 689 CALL OUT IVAL = LLEN LC = LC+IVAL IF(LL-LEN) 686,1,1 C GET CROSS REFERENCES FOR PASS 2 690 IF(LREF) 800,800,692 692 CALL SCAN(IARG,IVAL) IERR = 1 C 800 IF(IERR-4) 805,920,805 805 LLEN = LEN C OUTPUT CURRENT LINE CALL LOUT(MODE) C OUTPUT OBJECT CODE IF(LLEN) 830,850,830 830 CALL OUT C CHECK FOR END CARD 850 IF(IEND) 855,1,855 855 CALL OUT 859 WRITE(IPRT,1002) IERRS 1002 FORMAT(//,27H TOTAL ASSEMBLER ERRORS =,I5) RETURN C C ASSEMBLER ERRORS C C UNDEFINED LABEL IN ARGUMENT 900 IERRI(2) = ICHRU GO TO 990 C ARGUMENT ERROR (MISSING OR ILLEGAL) 910 IERRI(2) = ICHRA GO TO 990 C FORMAT ERROR 920 IERRI(2) = ICHRF GO TO 990 C SYNTAX ERROR 930 IERRI(2) = ICHRS GO TO 990 C VALUE ERROR - VALUE NOT WITHIN RANGE 940 IERRI(2) = ICHRV GO TO 990 C KEYWORD ERROR 960 IERRI(2) = ICHRK GO TO 990 C QUESTIONABLE OPERANDS 970 IERRI(2) = ICHRQ 990 IERRS = IERRS+1 IERRI(4) = 1 IERR = 1 GO TO 800 END SUBROUTINE OPCOD(ICOL,ICHK) C C C THE FOLLOWING DATA TABLE DEFINES ALL LEGAL MNEMONICS AND C DIRECTIVES. EACH DATA STATEMENT CONSISTS OF FOUR OR FIVE C CHARACTERS REPRESENTING THE MNEMONIC OR DIRECTIVE, FOLLOWED BY C THE INSTRUCTION TYPE AND ITS DECIMAL NUMERIC EQUIVALENT. C C REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION INST(5,81),INSTE(6,3) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE C COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) DATA INST(1, 1),INST(2, 1),INST(3, 1),INST(4, 1),INST(5, 1) 1 /1HJ,1HP,1H ,1H ,19194/ DATA INST(1, 2),INST(2, 2),INST(3, 2),INST(4, 2),INST(5, 2) 1 /1HC,1HA,1HL,1HL,18196/ DATA INST(1, 3),INST(2, 3),INST(3, 3),INST(4, 3),INST(5, 3) 1 /1HJ,1HR,1H ,1H ,17016/ DATA INST(1, 4),INST(2, 4),INST(3, 4),INST(4, 4),INST(5, 4) 1 /1HR,1HE,1HT,1H ,16192/ DATA INST(1, 5),INST(2, 5),INST(3, 5),INST(4, 5),INST(5, 5) 1 /1HI,1HN,1H ,1H ,15064/ DATA INST(1, 6),INST(2, 6),INST(3, 6),INST(4, 6),INST(5, 6) 1 /1HO,1HU,1HT,1H ,14065/ DATA INST(1, 7),INST(2, 7),INST(3, 7),INST(4, 7),INST(5, 7) 1 /1HA,1HD,1HD,1H ,13128/ DATA INST(1, 8),INST(2, 8),INST(3, 8),INST(4, 8),INST(5, 8) 1 /1HA,1HD,1HC,1H ,13136/ DATA INST(1, 9),INST(2, 9),INST(3, 9),INST(4, 9),INST(5, 9) 1 /1HS,1HB,1HC,1H ,13152/ DATA INST(1,10),INST(2,10),INST(3,10),INST(4,10),INST(5,10) 1 /1HB,1HI,1HT,1H ,12064/ DATA INST(1,11),INST(2,11),INST(3,11),INST(4,11),INST(5,11) 1 /1HR,1HE,1HS,1H ,12128/ DATA INST(1,12),INST(2,12),INST(3,12),INST(4,12),INST(5,12) 1 /1HS,1HE,1HT,1H ,12192/ DATA INST(1,13),INST(2,13),INST(3,13),INST(4,13),INST(5,13) 1 /1HE,1HX,1H ,1H ,11000/ DATA INST(1,14),INST(2,14),INST(3,14),INST(4,14),INST(5,14) 1 /1HL,1HD,1H ,1H ,10000/ DATA INST(1,15),INST(2,15),INST(3,15),INST(4,15),INST(5,15) 1 /1HP,1HU,1HS,1HH, 9197/ DATA INST(1,16),INST(2,16),INST(3,16),INST(4,16),INST(5,16) 1 /1HP,1HO,1HP,1H , 9193/ DATA INST(1,17),INST(2,17),INST(3,17),INST(4,17),INST(5,17) 1 /1HS,1HU,1HB,1H , 8144/ DATA INST(1,18),INST(2,18),INST(3,18),INST(4,18),INST(5,18) 1 /1HA,1HN,1HD,1H , 8160/ DATA INST(1,19),INST(2,19),INST(3,19),INST(4,19),INST(5,19) 1 /1HX,1HO,1HR,1H , 8168/ DATA INST(1,20),INST(2,20),INST(3,20),INST(4,20),INST(5,20) 1 /1HO,1HR,1H ,1H , 8176/ DATA INST(1,21),INST(2,21),INST(3,21),INST(4,21),INST(5,21) 1 /1HC,1HP,1H ,1H , 8184/ DATA INST(1,22),INST(2,22),INST(3,22),INST(4,22),INST(5,22) 1 /1HI,1HN,1HC,1H , 8004/ DATA INST(1,23),INST(2,23),INST(3,23),INST(4,23),INST(5,23) 1 /1HD,1HE,1HC,1H , 8005/ DATA INST(1,24),INST(2,24),INST(3,24),INST(4,24),INST(5,24) 1 /1HR,1HL,1HC,1H , 7000/ DATA INST(1,25),INST(2,25),INST(3,25),INST(4,25),INST(5,25) 1 /1HR,1HR,1HC,1H , 7008/ DATA INST(1,26),INST(2,26),INST(3,26),INST(4,26),INST(5,26) 1 /1HR,1HL,1H ,1H , 7016/ DATA INST(1,27),INST(2,27),INST(3,27),INST(4,27),INST(5,27) 1 /1HR,1HR,1H ,1H , 7024/ DATA INST(1,28),INST(2,28),INST(3,28),INST(4,28),INST(5,28) 1 /1HS,1HL,1HA,1H , 7032/ DATA INST(1,29),INST(2,29),INST(3,29),INST(4,29),INST(5,29) 1 /1HS,1HR,1HA,1H , 7040/ DATA INST(1,30),INST(2,30),INST(3,30),INST(4,30),INST(5,30) 1 /1HS,1HR,1HL,1H , 7056/ DATA INST(1,31),INST(2,31),INST(3,31),INST(4,31),INST(5,31) 1 /1HD,1HJ,1HN,1HZ, 6016/ DATA INST(1,32),INST(2,32),INST(3,32),INST(4,32),INST(5,32) 1 /1HR,1HS,1HT,1H , 5199/ DATA INST(1,33),INST(2,33),INST(3,33),INST(4,33),INST(5,33) 1 /1HI,1HM,1H ,1H , 5070/ DATA INST(1,34),INST(2,34),INST(3,34),INST(4,34),INST(5,34) 1 /1HL,1HD,1HI,1H , 4160/ DATA INST(1,35),INST(2,35),INST(3,35),INST(4,35),INST(5,35) 1 /1HL,1HD,1HI,1HR, 4176/ DATA INST(1,36),INST(2,36),INST(3,36),INST(4,36),INST(5,36) 1 /1HL,1HD,1HD,1H , 4168/ DATA INST(1,37),INST(2,37),INST(3,37),INST(4,37),INST(5,37) 1 /1HL,1HD,1HD,1HR, 4184/ DATA INST(1,38),INST(2,38),INST(3,38),INST(4,38),INST(5,38) 1 /1HC,1HP,1HI,1H , 4161/ DATA INST(1,39),INST(2,39),INST(3,39),INST(4,39),INST(5,39) 1 /1HC,1HP,1HI,1HR, 4177/ DATA INST(1,40),INST(2,40),INST(3,40),INST(4,40),INST(5,40) 1 /1HC,1HP,1HD,1H , 4169/ DATA INST(1,41),INST(2,41),INST(3,41),INST(4,41),INST(5,41) 1 /1HC,1HP,1HD,1HR, 4185/ DATA INST(1,42),INST(2,42),INST(3,42),INST(4,42),INST(5,42) 1 /1HN,1HE,1HG,1H , 4068/ DATA INST(1,43),INST(2,43),INST(3,43),INST(4,43),INST(5,43) 1 /1HR,1HE,1HT,1HI, 4077/ DATA INST(1,44),INST(2,44),INST(3,44),INST(4,44),INST(5,44) 1 /1HR,1HL,1HD,1H , 4111/ DATA INST(1,45),INST(2,45),INST(3,45),INST(4,45),INST(5,45) 1 /1HR,1HR,1HD,1H , 4103/ DATA INST(1,46),INST(2,46),INST(3,46),INST(4,46),INST(5,46) 1 /1HR,1HE,1HT,1HN, 4069/ DATA INST(1,47),INST(2,47),INST(3,47),INST(4,47),INST(5,47) 1 /1HI,1HN,1HI,1H , 4162/ DATA INST(1,48),INST(2,48),INST(3,48),INST(4,48),INST(5,48) 1 /1HI,1HN,1HI,1HR, 4178/ DATA INST(1,49),INST(2,49),INST(3,49),INST(4,49),INST(5,49) 1 /1HI,1HN,1HD,1H , 4170/ DATA INST(1,50),INST(2,50),INST(3,50),INST(4,50),INST(5,50) 1 /1HI,1HN,1HD,1HR, 4186/ DATA INST(1,51),INST(2,51),INST(3,51),INST(4,51),INST(5,51) 1 /1HO,1HU,1HT,1HI, 4163/ DATA INST(1,52),INST(2,52),INST(3,52),INST(4,52),INST(5,52) 1 /1HO,1HT,1HI,1HR, 4179/ DATA INST(1,53),INST(2,53),INST(3,53),INST(4,53),INST(5,53) 1 /1HO,1HU,1HT,1HD, 4171/ DATA INST(1,54),INST(2,54),INST(3,54),INST(4,54),INST(5,54) 1 /1HO,1HT,1HD,1HR, 4187/ DATA INST(1,55),INST(2,55),INST(3,55),INST(4,55),INST(5,55) 1 /1HE,1HX,1HX,1H , 3217/ DATA INST(1,56),INST(2,56),INST(3,56),INST(4,56),INST(5,56) 1 /1HD,1HA,1HA,1H , 3039/ DATA INST(1,57),INST(2,57),INST(3,57),INST(4,57),INST(5,57) 1 /1HC,1HP,1HL,1H , 3047/ DATA INST(1,58),INST(2,58),INST(3,58),INST(4,58),INST(5,58) 1 /1HC,1HC,1HF,1H , 3063/ DATA INST(1,59),INST(2,59),INST(3,59),INST(4,59),INST(5,59) 1 /1HS,1HC,1HF,1H , 3055/ DATA INST(1,60),INST(2,60),INST(3,60),INST(4,60),INST(5,60) 1 /1HR,1HL,1HC,1HA, 3007/ DATA INST(1,61),INST(2,61),INST(3,61),INST(4,61),INST(5,61) 1 /1HR,1HR,1HC,1HA, 3015/ DATA INST(1,62),INST(2,62),INST(3,62),INST(4,62),INST(5,62) 1 /1HR,1HL,1HA,1H , 3023/ DATA INST(1,63),INST(2,63),INST(3,63),INST(4,63),INST(5,63) 1 /1HR,1HR,1HA,1H , 3031/ DATA INST(1,64),INST(2,64),INST(3,64),INST(4,64),INST(5,64) 1 /1HN,1HO,1HP,1H , 3000/ DATA INST(1,65),INST(2,65),INST(3,65),INST(4,65),INST(5,65) 1 /1HH,1HA,1HL,1HT, 3118/ DATA INST(1,66),INST(2,66),INST(3,66),INST(4,66),INST(5,66) 1 /1HD,1HI,1H ,1H , 3243/ DATA INST(1,67),INST(2,67),INST(3,67),INST(4,67),INST(5,67) 1 /1HE,1HI,1H ,1H , 3251/ DATA INST(1,68),INST(2,68),INST(3,68),INST(4,68),INST(5,68) 1 /1HO,1HR,1HG,1H , 1001/ DATA INST(1,69),INST(2,69),INST(3,69),INST(4,69),INST(5,69) 1 /1HE,1HQ,1HU,1H , 1002/ DATA INST(1,70),INST(2,70),INST(3,70),INST(4,70),INST(5,70) 1 /1HD,1HE,1HF,1HB, 1003/ DATA INST(1,71),INST(2,71),INST(3,71),INST(4,71),INST(5,71) 1 /1HD,1HE,1HF,1HS, 1004/ DATA INST(1,72),INST(2,72),INST(3,72),INST(4,72),INST(5,72) 1 /1HD,1HE,1HF,1HW, 1005/ DATA INST(1,73),INST(2,73),INST(3,73),INST(4,73),INST(5,73) 1 /1HE,1HN,1HD,1H , 1006/ DATA INST(1,74),INST(2,74),INST(3,74),INST(4,74),INST(5,74) 1 /1HE,1HJ,1HE,1HC, 1007/ DATA INST(1,75),INST(2,75),INST(3,75),INST(4,75),INST(5,75) 1 /1HL,1HI,1HS,1HT, 1009/ DATA INST(1,76),INST(2,76),INST(3,76),INST(4,76),INST(5,76) 1 /1HS,1HP,1HA,1HC, 1011/ DATA INST(1,77),INST(2,77),INST(3,77),INST(4,77),INST(5,77) 1 /1HD,1HE,1HF,1HL, 1012/ DATA INST(1,78),INST(2,78),INST(3,78),INST(4,78),INST(5,78) 1 /1HI,1HF,1H ,1H , 1014/ DATA INST(1,79),INST(2,79),INST(3,79),INST(4,79),INST(5,79) 1 /1HM,1HA,1HC,1HR, 1016/ DATA INST(1,80),INST(2,80),INST(3,80),INST(4,80),INST(5,80) 1 /1HD,1HE,1HF,1HM, 1018/ DATA INST(1,81),INST(2,81),INST(3,81),INST(4,81),INST(5,81) 1 /1HE,1HN,1HD,1HM, 1017/ DATA INSTE(1,1),INSTE(2,1),INSTE(3,1),INSTE(4,1),INSTE(5,1), 1 INSTE(6,1) /1HN,1HL,1HI,1HS,1HT,1010/ DATA INSTE(1,2),INSTE(2,2),INSTE(3,2),INSTE(4,2),INSTE(5,2), 1 INSTE(6,2) /1HE,1HN,1HD,1HI,1HF, 1015/ DATA INSTE(1,3),INSTE(2,3),INSTE(3,3),INSTE(4,3),INSTE(5,3), 1 INSTE(6,3) /1HT,1HI,1HT,1HL,1HE,1013/ C C *ENTRY PARAMETERS C ICOL - STARTING COLUMN OF SCAN FOR OPCODE C C *EXIT PARAMETERS C ICOL - END OF OPCODE +1, OR BEGINNING OF LABEL IF IERR = 6 C ITYPE - INSTRUCTION TYPE C -1 = COMMENT (SET IN PASS 1) C 0 = ERROR C 1 = DIRECTIVE C 2 = MACRO CALL C 3 = INHERENT - 1 BYTE C 4 = INHERENT - 2 BYTE C 5 = RST C 6 = DJNZ C 7 = ROTATES AND SHIFTS C 8 = ACCUMULATOR AND OPERAND GROUP - 1 OPERAND C 9 = PUSH AND POP C 10 = LD C 11 = EX C 12 = BIT,RES,SET C 13 = AND,ADC,SBC C 14 = OUT C 15 = IN C 16 = RET C 17 = JR C 18 = CALL C 19 = JP C IOPVA - VALUE OF INSTRUCTION C ICHK - 1000*ITYPE+IOPVA C ICNT - LENGTH OF OPCODE C IERR - ERROR STATUS C 1 = VALID OPCODE C 2 = VALID FORMAT - PRESUMED MACRO NAME C 3 = OPCODE ERROR C 4 = COMMENT LINE C 5 = NO OPCODE ON LINE C 6 = SYMBOL END WITH A COLON, PRESUMED LABEL C NUMOP = 81 ITYPE = 0 IOPVA = 0 ICHK=0 ICNT = 0 IERR = 1 INSTT = 0 ILEN = 4 C LOOK FOR START OF OPCODE 100 IF(IN(ICOL)-IBLNK) 105,115,105 105 IF(IN(ICOL)-ICTAB) 110,115,110 C CHECK FOR COMMENT LINE 110 IF(IN(ICOL)-ISEMI) 120,920,120 115 ICOL = ICOL+1 IF(ICOL-MCOL) 100,100,930 C FOUND START OF OPCODE, CHECK FOR A MACRO 120 J1 = ICOL IF(MCNT) 200,200,130 130 CALL SYMBL(ICOL) GO TO(150,910,200,910),IERR 150 DO 170 L=1,MCNT DO 160 K=1,IWORD IF(MCNAM(K,L)-NAME(K)) 170,160,170 160 CONTINUE IOPVA = L ITYPE = 2 ICHK = 2000+L GO TO 600 170 CONTINUE C GET END OF OPCODE AND CHECK FOR VALIDITY 200 ICOL = J1 ICNT = 0 210 IF(IN(ICOL)-IBLNK) 220,260,220 220 IF(IN(ICOL)-ISEMI) 230,260,230 230 IF(IN(ICOL)-ICTAB) 235,260,235 235 IF(IN(ICOL)-ICOLN) 240,940,240 240 ICNT = ICNT+1 ICOL = ICOL+1 IF(ICNT-MOPC) 250,250,910 250 IF(ICOL-MCOL) 210,210,260 260 IF(ICNT-ILEN) 300,300,270 270 ILEN = 5 INSTT = 1 NUMOP = 3 C CHECK OPCODE AGAINST ALL LEGAL OPCODES 300 DO 370 L=1,NUMOP DO 330 K=1,ICNT K1 = J1+K-1 IF(INSTT) 310,310,320 310 IF(IN(K1)-INST(K,L)) 370,330,370 320 IF(IN(K1)-INSTE(K,L)) 370,330,370 330 CONTINUE IF(ICNT-ILEN) 340,500,500 340 K2 = ICNT+1 IF(INSTT) 350,350,360 350 IF(INST(K2,L)-IBLNK) 370,500,370 360 IF(INSTE(K2,L)-IBLNK) 370,500,370 370 CONTINUE GO TO 910 C FETCH INSTRUCTION TYPE AND VALUE 500 ICHK = INST(5,L) IF(INSTT) 550,550,510 510 ICHK = INSTE(6,L) 550 ITYPE = ICHK/1000 IOPVA = ICHK-ITYPE*1000 C SCAN TO START OF ARGUMENT FIELD 600 IF(IN(ICOL)-IBLNK) 650,610,650 610 ICOL = ICOL+1 IF(ICOL-MCOL) 600,600,650 650 IARG = ICOL RETURN C OPCODE ERROR 910 IERR = 3 RETURN C FOUND COMMENT INDICATOR 920 IERR = 4 RETURN C NO OPCODE ON LINE 930 IERR = 5 RETURN C PRESUMED LABEL 940 IERR = 6 ICOL = J1 RETURN END SUBROUTINE LABEL(ICOL,IVAL,MODE) C C C THIS ROUTINE PROCESSES ALL SYMBOLS USED IN THE ASSEMBLY C PROGRAM. IT SCANS THE SYMBOL TABLE TO SEE IF A GIVEN SYMBOL C IS DEFINED OR NOT C C REAL IVAL REAL LC,LODLC,IPVAL,ITABV(200) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) C C C C *ENTRY PARAMETERS C ICOL - STARTING COLUMN OF SCAN C MODE - REFERENCE OR DEFINITION FLAG C 0 = DEFINITION C 1 = REFERENCE C C *EXIT PARAMETERS C ICOL - ENDING COLUMN OF SCAN C IVAL - VALUE OF LABEL C IERR - ERROR STATUS C 1 = VALID SYMBOL FOUND C 2 = SYMBOL NOT IN TABLE C 3 = SYMBOL ERROR C 4 = SYMBOL TABLE FULL C ISSYM - INDICATES A DEFL SYMBOL IF SET TO 1 C ISSYM = 0 IVAL = 0 NOTRY = 0 C FETCH LABEL AND ITS INDEX CALL SYMBL(ICOL) IF(IERR-4) 100,920,100 C CHECK IF LABEL IS IN TABLE 100 INDEX = 3*INDEX 150 IF(INDEX-LTAB) 160,160,155 155 INDEX = INDEX-LTAB GO TO 150 C CHECK FOR EMPTY SLOT IN TABLE 160 IF(ITAB(1,INDEX)) 165,910,165 165 DO 170 J=1,IWORD IF(ITAB(J,INDEX)-NAME(J)) 200,170,200 170 CONTINUE GO TO 800 C TRY NEXT SLOT IN TABLE 200 NOTRY = NOTRY+1 INDEX = INDEX+1 IF(NOTRY-LTAB) 150,940,940 C CHECK IF A DEFL SYMBOL 800 IVAL = ITABV(INDEX) IF(IVAL-100000.) 900,810,810 810 IVAL = IVAL-100000. ISSYM = 1 C SYMBOL FOUND 900 IERR = 1 IF(MODE+IPASS+LREF-4) 945,905,945 905 CALL XREFT(MODE,0) RETURN C SYMBOL NOT IN TABLE 910 IERR = 2 RETURN C SYMBOL ERROR 920 IERR = 3 RETURN C SYMBOL TABLE FULL 940 IERR = 4 945 RETURN END SUBROUTINE SYMBL(ICOL) C C C THIS SUBROUTINE IS USED TO FORM A SYMBOL AND ITS INDEX C INTO THE SYMBOL TABLE C C REAL LC,LODLC,IPVAL,ITABV(200) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) C C *ENTRY PARAMETERS C ICOL - STARTING COLUMN OF SCAN C C *EXIT PARAMETERS C ICOL - ENDING COLUMN OF SCAN C NAME - CONTAINS NUMERIC EQUIVALENT OF SYMBOL C LABCT - NUMBER OF CHARACTERS IN SYMBOL C IERR - ERROR STATUS C 1 = SYMBOL ENDS WITH BLANK,SEMICOLON, OR TAB C 2 = SYMBOL ENDS WITH A COMMA C 3 = SYMBOL ENDS WITH OTHER THAN 1 OR 2 C 4 = SYMBOL ERROR C INDEX = 0 LABCT = 0 DO 10 J=1,IWORD NAME(J) = 0 10 CONTINUE IC1 = 1 IC2 = 1 C CHECK FOR VALID CHARACTER 100 DO 110 J=1,41 IF(IN(ICOL)-IALPH(J)) 110,130,110 110 CONTINUE C END OF SCAN IF FOUND INVALID CHARACTER IF(LABCT) 115,930,115 115 IF(IC2-ICCNT) 116,116,120 116 DO 117 J=IC2,ICCNT NAME(IC1) = NAME(IC1)*256 117 CONTINUE C CHECK FOR BLANK OR COMMA 120 IF(IN(ICOL)-IBLNK) 122,900,122 122 IF(IN(ICOL)-ISEMI) 125,900,125 125 IF(IN(ICOL)-ICOMM) 126,910,126 126 IF(IN(ICOL)-ICTAB) 920,900,920 C CHECK IF MORE CHARACTER THAN WILL FIT IN TABLE 130 IF(LABCT-MLAB) 132,160,160 132 IF(LABCT) 134,134,140 134 IF(J-10) 930,930,140 140 LABCT = LABCT+1 C CALCULATE INDEX INTO SYMBOL TABLE INDEX = INDEX+J IF(IC2-ICCNT) 150,150,142 142 IC1 = IC1+1 IC2 = 1 150 IC2 = IC2+1 C FORM SYMBOL FOR PLACEMENT IN TABLE NAME(IC1) = NAME(IC1)*256+J 160 IF(ICOL-MCOL) 162,930,930 162 ICOL = ICOL+1 GO TO 100 C SYMBOL END WITH A BLANK OR SEMICOLON OR TAB 900 IERR = 1 RETURN C SYMBOL ENDS WITH A COMMA 910 IERR = 2 RETURN C SYMBOL ENDS WITH OTHER THAN A BLANK, COMMA, OR SEMICOLON 920 IERR = 3 RETURN C SYMBOL ERROR 930 IERR = 4 RETURN END SUBROUTINE SCAN(ICOL,IVAL) C C C THIS SUBROUTINE IS USED TO EVALUATE A GENERAL EXPRESSION C AND RETURNS A VALUE REPRESENTING THE EXPRESSION TO THE C CALLING PROGRAM. THE METHOD USED IS INFIX TO POLISH C CONVERSION AND THEN AN EVALUATION OF THE POLISH STRING C C REAL IVAL,IVAL1,MDIV,IOP1,IOP2,ISTK2(80) REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION ISTK1(80),IOPER(12),IPREC(20),ISYM(17),NOPER(3,13) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (IOPER(1),IPLUS) EQUIVALENCE (ISYM(1),IBLNK) DATA IPREC( 1),IPREC( 2),IPREC( 3),IPREC( 4) /11,11,13,13/ DATA IPREC( 5),IPREC( 6),IPREC( 7),IPREC( 8) /0,21,9,3/ DATA IPREC( 9),IPREC(10),IPREC(11),IPREC(12) /3,3,7,5/ DATA IPREC(13),IPREC(14),IPREC(15),IPREC(16) /5,13,13,13/ DATA IPREC(17),IPREC(18),IPREC(19),IPREC(20) /3,3,1,15/ DATA NOPER(1, 1),NOPER(2, 1),NOPER(3, 1) /1HN,1HO,1HT/ DATA NOPER(1, 2),NOPER(2, 2),NOPER(3, 2) /1HE,1HQ,1H / DATA NOPER(1, 3),NOPER(2, 3),NOPER(3, 3) /1HG,1HT,1H / DATA NOPER(1, 4),NOPER(2, 4),NOPER(3, 4) /1HL,1HT,1H / DATA NOPER(1, 5),NOPER(2, 5),NOPER(3, 5) /1HA,1HN,1HD/ DATA NOPER(1, 6),NOPER(2, 6),NOPER(3, 6) /1HO,1HR,1H / DATA NOPER(1, 7),NOPER(2, 7),NOPER(3, 7) /1HX,1HO,1HR/ DATA NOPER(1, 8),NOPER(2, 8),NOPER(3, 8) /1HM,1HO,1HD/ DATA NOPER(1, 9),NOPER(2, 9),NOPER(3, 9) /1HS,1HH,1HL/ DATA NOPER(1,10),NOPER(2,10),NOPER(3,10) /1HS,1HH,1HR/ DATA NOPER(1,11),NOPER(2,11),NOPER(3,11) /1HU,1HG,1HT/ DATA NOPER(1,12),NOPER(2,12),NOPER(3,12) /1HU,1HL,1HT/ DATA NOPER(1,13),NOPER(2,13),NOPER(3,13) /1HR,1HE,1HS/ C C C *ENTRY PARAMETERS C ICOL - STARTING COLUMN OF SCAN C NSPAR - INDICATES USE LEFT PARENTHESIS AS FIRST CHARACTER C C *EXIT PARAMETERS C ICOL - ENDING COLUMN OF SCAN C IVAL - VALUE OF EXPRESSION ON RETURN C NSPAR - SET TO ZERO C IERR - ERROR STATUS C 1 = NO ERRORS C 2 = MISSING ARGUMENT OR ARGUMENT ERROR C 3 = UNDEFINED SYMBOL C 4 = NO ERROR, SCAN ENDED WITH A COMMA C 5 = SYNTAX ERROR C IF(ICOL-MCOL) 10,10,920 10 NEXP = -2 NUNDS = 0 NUARY = 1 NEND = 0 IVAL = 0 NPNTO = 81 NPRCS = 0 IPNTS = 1 LLEN = 0 ISTK1(1) = 0 ISTK2(1) = 0 IF(NSPAR) 100,100,20 20 ICHAR = ILPAR NSPAR = 0 ICOL = ICOL-1 GO TO 105 100 ICHAR = IN(ICOL) IF(ICOL-MCOL) 105,105,118 C CHECK FOR AN OPERATOR 105 DO 110 L=1,12 IF(ICHAR-IOPER(L)) 110,200,110 110 CONTINUE C CHECK FOR SCAN TERMINATOR (COMMA,BLANK, SEMICOLON) IERR = 4 IF(ICHAR-ICOMM) 112,119,112 112 IF(ICHAR-IBLNK) 114,118,114 114 IF(ICHAR-ISEMI) 116,118,116 116 IF(ICHAR-ICTAB) 120,118,120 118 IERR = 1 119 NPRCI = 0 NEND = 1 GO TO 300 C CHECK FOR OPERATOR DELIMITED BY PERIODS 120 IF(ICHAR-IPER) 130,121,130 121 ICOL1 = ICOL J = 0 122 ICOL = ICOL+1 IF(IN(ICOL)-IPER) 123,124,123 123 J = J+1 IF(J-3) 122,122,910 C CHECK IF VALID OPERATOR 124 DO 127 LL=1,13 DO 125 N=1,J L = ICOL1+N IF(IN(L)-NOPER(N,LL)) 127,125,127 125 CONTINUE C VALID OPERATOR SET OPERATOR INDEX L = LL+6 IF(J-3) 126,200,200 126 J = J+1 IF(NOPER(J,LL)-IBLNK) 920,200,920 127 CONTINUE GO TO 920 C CHECK FOR AN OPERAND 130 NUARY = 0 IVAL = 0 IF(NEXP+1) 140,910,140 C CHECK FOR NUMERIC OPERAND 140 DO 1410 J=1,10 IF(ICHAR-IALPH(J)) 1410,1420,1410 1410 CONTINUE GO TO 150 C FOUND NUMERIC, LOOK FOR TERMINATOR 1420 N1 = ICOL 1425 ICOL = ICOL+1 IF(ICOL-MCOL) 1430,1430,1440 1430 ICHAR = IN(ICOL) DO 1435 LL=1,17 IF(ISYM(LL)-ICHAR) 1435,1440,1435 1435 CONTINUE GO TO 1425 1440 ICOL1 = ICOL-1 C CHECK FOR CONSTANT TYPE (B,D,O,Q,H) ICHAR = IN(ICOL1) IFACT = 2 C BINARY CONSTANT IF(ICHAR-ICHRB) 1445,1470,1445 C OCTAL CONSTANT 1445 IFACT = 8 IF(ICHAR-ICHRO) 1450,1470,1450 1450 IF(ICHAR-ICHRQ) 1455,1470,1455 C HEXADECIMAL CONSTANT 1455 IFACT = 16 IF(ICHAR-ICHRH) 1460,1470,1460 C DECIMAL CONSTANT 1460 IFACT = 10 IF(ICHAR-ICHRD) 1465,1470,1465 1465 ICOL1 = ICOL 1470 ICOL1 = ICOL1-1 C FORM NUMERIC VALUE IOP1 = IFACT DO 1490 LL=N1,ICOL1 DO 1480 K=1,IFACT IF(IN(LL)-IALPH(K)) 1480,1485,1480 1480 CONTINUE GO TO 910 1485 IOP2 = K-1 IVAL = IVAL*IOP1+IOP2 1490 CONTINUE GO TO 190 C CHECK FOR LOCATION COUNTER REFERENCE 150 IF(ICHAR-IDOLR) 160,155,160 155 IVAL = LC ICOL = ICOL+1 GO TO 190 160 CALL CONST(ICOL,IVAL) GO TO (170,920,180,910),IERR 170 IF(LLEN) 915,915,172 172 IF(LLEN-2) 190,174,915 174 IVAL1 = NBIN(2) IVAL = IVAL*256.+IVAL1 GO TO 190 C CHECK FOR SYMBOL OPERAND 180 CALL LABEL(ICOL,IVAL,1) GO TO(190,185,920,930),IERR 185 IVAL = 0 NUNDS = 1 C FOUND OPERAND, PLACE IT IN OUTPUT STACK 190 NPNTO = NPNTO-1 ISTK1(NPNTO) = 0 ISTK2(NPNTO) = IVAL NEXP = -1 GO TO 100 C HAVE AN OPERATOR, PLACE IN INPUT STACK 200 NPRCI = IPREC(L) C CHECK IF PREVIOUS TOKEN WAS AN OPERATOR - IF SO CHECK SYNTAX IF(NEXP) 250,205,205 C CHECK IF RIGHT PARENTHESIS 205 IF(L-5) 215,210,215 210 IF(NEXP-5) 910,270,910 C CHECK IF LEFT PARENTHESIS 215 IF(L-6) 225,220,225 220 NUARY = 1 IF(NEXP-5) 270,910,270 C CHECK IF PREVIOUS TOKEN WAS LEFT PARENTHESIS 225 IF(NEXP-6) 240,230,240 230 IF(L-7) 235,270,235 235 IF(L-2) 270,270,910 C CHECK IF PREVIOUS TOKEN RIGHT PARENTHESIS 240 IF(NEXP-5) 910,245,910 245 IF(L-7) 250,910,250 C CHECK IF EXPONENTIATION 250 IF(L-3) 270,255,270 255 ICOL1 = ICOL+1 IF(IN(ICOL1)-IMULT) 270,260,270 260 L = 20 NPRCI = 15 ICOL = ICOL1 270 NEXP = L C CHECK IF UNARY PLUS OR MINUS IF(L-2) 275,275,300 275 IF(NUARY) 300,300,280 280 L = L+4 NPRCI = 17 C PERFORM INFIX TO POLISH CONVERSION C CHECK IF INPUT STACK IS EMPTY 300 IF(IPNTS) 310,920,310 C COMPARE INPUT STRING PRECEDENCE TO INPUT STACK PRECEDENCE 310 IF(NPRCI-NPRCS) 400,410,420 C STACK PRECEDENCE GREATER THAN INPUT STRING PRECEDENCE 400 NPNTO = NPNTO-1 ISTK1(NPNTO) = ISTK1(IPNTS) ISTK2(NPNTO) = 0 IPNTS = IPNTS-1 NPRCS = ISTK2(IPNTS) GO TO 300 C STACK PRECEDENCE EQUALS INPUT STRING PRECEDENCE 410 IPNTS = IPNTS-1 IF(NEND-1) 412,415,412 412 IF(IPNTS) 910,910,414 414 NPRCS = ISTK2(IPNTS) GO TO 430 C CHECK FOR EMPTY INPUT STACK 415 IF(IPNTS-1) 417,910,910 C PLACE END INDICATOR IN OUTPUT STACK 417 NPNTO = NPNTO-1 ISTK1(NPNTO) = -1 GO TO 500 C STACK PRECEDENCE LESS THAN INPUT STRING PRECEDENCE 420 IPNTS = IPNTS+1 ISTK1(IPNTS) = L IF(NPRCI-21) 424,422,424 422 NPRCI = -1 424 NPRCS = NPRCI+1 ISTK2(IPNTS) = NPRCS 430 ICOL = ICOL+1 GO TO 100 C C EVALUATE EXPRESSION C C CHECK IF OUTPUT STACK IS EMPTY 500 NPNTE = 0 IF(NPNTO-80) 505,920,920 505 NPNTO = 81 C GET NEXT ENTRY IN STACK 510 NPNTO = NPNTO-1 ICHAR = ISTK1(NPNTO) IF(ICHAR) 520,540,560 C END OF STACK - CHECK FOR ONLY ONE ENTRY IN EVALUATION C STACK WHICH IS THE EXPRESSION VALUE 520 IF(NPNTE-1) 910,530,910 530 IVAL = ISTK2(1) LLEN = 1 GO TO 905 C THIS IS AN OPERAND - PLACE IN EVALUATION STACK 540 NPNTE = NPNTE+1 IVAL = ISTK2(NPNTO) GO TO 810 C THIS IS AN OPERATOR - PERFORM NECESSARY OPERATION 560 IF(NPNTE-1) 910,562,566 562 IF(ICHAR-4) 910,910,564 564 IF(ICHAR-7) 568,568,565 565 IF(ICHAR-19) 910,568,910 566 NPNT1 = NPNTE-1 IOP2 = ISTK2(NPNT1) 568 IOP1 = ISTK2(NPNTE) IVAL = 0 GO TO(570,580,590,600,610,620,630,640,650,660,670, 1 680,690,700,710,720,730,740,750,760),ICHAR C ADDITION 570 IVAL = IOP2+IOP1 GO TO 800 C SUBTRACTION 580 IVAL = IOP2-IOP1 GO TO 800 C MULTIPLICATION 590 IVAL = IOP2*IOP1 GO TO 800 C DIVISION 600 IF(IOP1) 602,810,602 602 J = IOP2/IOP1 IVAL = J GO TO 800 C UNARY ADDITION 610 GO TO 510 C UNARY SUBTRACTION 620 IVAL = -IOP1 GO TO 810 C .NOT. 630 IVAL = 65535.-IOP1 GO TO 810 C .EQ. 640 IF(IOP1-IOP2) 800,790,800 C .GT. 650 IF(IOP1-32768.) 652,651,651 651 IOP1 = IOP1-65536. 652 IF(IOP2-32768.) 730,653,653 653 IOP2 = IOP2-65536. GO TO 730 C .LT. 660 IF(IOP1-32768.) 662,661,661 661 IOP1 = IOP1-65536. 662 IF(IOP2-32768.) 740,663,663 663 IOP2 = IOP2-65536. GO TO 740 C .AND. 670 IC1 = 2 IC2 = 2 GO TO 770 C .OR. 680 IC1 = 1 IC2 = 2 GO TO 770 C .XOR. 690 IC1 = 1 IC2 = 1 GO TO 770 C .MOD. 700 IVAL = IOP2 IF(IOP1) 705,800,705 705 J = IOP2/IOP1 IVAL = J IVAL = IOP2-IOP1*IVAL GO TO 800 C .SHL. 710 IF(IOP1-16.) 712,800,800 712 IC1 = IOP1 IVAL = 2**IC1 IVAL = IOP2*IVAL GO TO 800 C .SHR. 720 IF(IOP1-16.) 722,800,800 722 IC1 = IOP1 IVAL = 2**IC1 IVAL = IOP2/IVAL GO TO 800 C .UGT. 730 IF(IOP2-IOP1) 800,800,790 C .ULT. 740 IF(IOP2-IOP1) 790,800,800 C .RES. 750 GO TO 510 C EXPONENTIATION 760 IVAL = IOP2**IOP1 GO TO 800 C PERFORM BIT PROCESSING FOR AND,OR,XOR 770 MDIV = 32768. DO 778 I=1,16 IB1 = IOP1/MDIV IVAL1 = IB1 IOP1 = IOP1-IVAL1*MDIV IB2 = IOP2/MDIV IVAL1 = IB2 IOP2 = IOP2-IVAL1*MDIV IB1 = IB1+IB2 IF(IB1-IC1) 776,774,772 772 IF(IB1-IC2) 776,774,776 774 IVAL = IVAL+MDIV 776 MDIV = MDIV/2. 778 CONTINUE GO TO 800 C SET RELATIONSHIP TO TRUE 790 IVAL = 65535. C CHECK IF VALUE WITHIN RANGE 800 NPNTE = NPNT1 810 J = IVAL/65536. IVAL1 = J IVAL = IVAL-IVAL1*65536. IF(IVAL) 820,830,830 820 IVAL = IVAL+65536. 830 ISTK2(NPNTE) = IVAL GO TO 510 C CHECK FOR UNDEFINED SYMBOL 905 IF(NUNDS) 940,940,930 C SYNTAX ERROR 910 IERR = 5 RETURN C ARGUMENT ERROR 915 LLEN = 0 920 IERR = 2 RETURN C UNDEFINED SYMBOL 930 IERR = 3 940 RETURN END SUBROUTINE CONST(ICOL,IVAL) C C C THIS SUBROUTINE PROCESSES ALL CONSTANT STRINGS IN THE C ARGUMENT FIELD C C REAL LC,LODLC,IPVAL,ITABV(200) REAL IVAL DIMENSION IASCI(62),IEBCD(62) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) DATA IASCI( 1),IASCI( 2),IASCI( 3),IASCI( 4) /48,49,50,51/ DATA IASCI( 5),IASCI( 6),IASCI( 7),IASCI( 8) /52,53,54,55/ DATA IASCI( 9),IASCI(10),IASCI(11),IASCI(12) /56,57,65,66/ DATA IASCI(13),IASCI(14),IASCI(15),IASCI(16) /67,68,69,70/ DATA IASCI(17),IASCI(18),IASCI(19),IASCI(20) /71,72,73,74/ DATA IASCI(21),IASCI(22),IASCI(23),IASCI(24) /75,76,77,78/ DATA IASCI(25),IASCI(26),IASCI(27),IASCI(28) /79,80,81,82/ DATA IASCI(29),IASCI(30),IASCI(31),IASCI(32) /83,84,85,86/ DATA IASCI(33),IASCI(34),IASCI(35),IASCI(36) /87,88,89,90/ DATA IASCI(37),IASCI(38),IASCI(39),IASCI(40) /33,37,63,64/ DATA IASCI(41),IASCI(42),IASCI(43),IASCI(44) /95,32,34,35/ DATA IASCI(45),IASCI(46),IASCI(47),IASCI(48) /36,38,39,40/ DATA IASCI(49),IASCI(50),IASCI(51),IASCI(52) /41,42,43,44/ DATA IASCI(53),IASCI(54),IASCI(55),IASCI(56) /45,46,47,58/ DATA IASCI(57),IASCI(58),IASCI(59),IASCI(60) /59,60,61,62/ DATA IASCI(61),IASCI(62) /94,92/ DATA IEBCD( 1),IEBCD( 2),IEBCD( 3),IEBCD( 4) /240,241,242,243/ DATA IEBCD( 5),IEBCD( 6),IEBCD( 7),IEBCD( 8) /244,245,246,247/ DATA IEBCD( 9),IEBCD(10),IEBCD(11),IEBCD(12) /248,249,193,194/ DATA IEBCD(13),IEBCD(14),IEBCD(15),IEBCD(16) /195,196,197,198/ DATA IEBCD(17),IEBCD(18),IEBCD(19),IEBCD(20) /199,200,201,209/ DATA IEBCD(21),IEBCD(22),IEBCD(23),IEBCD(24) /210,211,212,213/ DATA IEBCD(25),IEBCD(26),IEBCD(27),IEBCD(28) /214,215,216,217/ DATA IEBCD(29),IEBCD(30),IEBCD(31),IEBCD(32) /226,227,228,229/ DATA IEBCD(33),IEBCD(34),IEBCD(35),IEBCD(36) /230,231,232,233/ DATA IEBCD(37),IEBCD(38),IEBCD(39),IEBCD(40) /90,108,111,124/ DATA IEBCD(41),IEBCD(42),IEBCD(43),IEBCD(44) /109,64,127,123/ DATA IEBCD(45),IEBCD(46),IEBCD(47),IEBCD(48) /91,80,125,77/ DATA IEBCD(49),IEBCD(50),IEBCD(51),IEBCD(52) /93,92,78,107/ DATA IEBCD(53),IEBCD(54),IEBCD(55),IEBCD(56) /96,75,97,122/ DATA IEBCD(57),IEBCD(58),IEBCD(59),IEBCD(60) /94,76,126,110/ DATA IEBCD(61),IEBCD(62) /79,224/ C C *ENTRY PARAMETERS C ICOL - STARTING COLUMN OF SCAN C C *EXIT PARAMETERS C ICOL - ENDING COLUMN OF SCAN C IVAL - 1ST BYTE OF CONSTANT ON RETURN C NBIN - ARRAY OF CONSTANT VALUES C IERR - ERROR STATUS C 1 = FOUND VALID CONSTANTS C 2 = ERROR IN DATA OR NO DATA FOUND C 3 = THIS IS NOT CONSTANT STRING FORMAT C 4 = EXPRESSION ERROR C NBIN(1) = 0 LLEN = 0 IF(ICOL-MCOL) 10,10,930 C CHECK FOR A LITERAL 10 ICOL1 = ICOL+1 NCHAR = IN(ICOL) IFACT = 1 IF(NCHAR-IQUOT) 15,200,15 15 IF(IN(ICOL1)-IQUOT) 920,20,920 20 ICOL = ICOL1 C ASCII CONSTANT 60 IFACT = 1 IF(NCHAR-ICHRA) 70,200,70 C EBCDIC CONSTANT 70 IFACT = 2 IF(NCHAR-ICHRE) 930,200,930 C C PROCESS ASCII OR EBCDIC CONSTANTS C 200 ICOL = ICOL+1 IF(ICOL-MCOL) 202,202,930 C C CHECK IF QUOTE IS USED AS CHARACTER C I.E. TO USE AS CHARACTER MUST BE USED TWICE IN SUCCESSION 202 IF(IN(ICOL)-IQUOT) 210,204,210 204 ICOL1 = ICOL+1 IF(IN(ICOL1)-IQUOT) 900,206,900 206 ICOL = ICOL1 210 LLEN = LLEN+1 DO 220 J=1,62 IF(IN(ICOL)-IALPH(J)) 220,250,220 220 CONTINUE GO TO 930 250 GO TO (260,270),IFACT C ASCII CONSTANT 260 NBIN(LLEN) = IASCI(J) GO TO 200 C EBCDIC CONSTANT 270 NBIN(LLEN) = IEBCD(J) GO TO 200 C C FOUND VALID DATA 900 ICOL = ICOL+1 IERR = 1 IF(LLEN) 930,930,950 C ERROR IN STRING FORMAT - NO QUOTE 920 IERR = 3 GO TO 950 C ERROR IN DATA OR NO DATA FOUND 930 IERR = 2 950 IVAL = NBIN(1) RETURN END SUBROUTINE MCDEF C C C THIS ROUTINE IS USED FOR MACRO DEFINITIONS. IT SCANS EACH C MODEL LINE AND CHECKS FOR MACRO PARAMETERS. IT PLACES C PARAMETER MARKERS AT THESE LOCATIONS SO THEY CAN BE C REFERENCED DURING MACRO EXPANSIONS AND REPLACED WITH ACTUAL C PARAMETERS. C C REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION MACIN(80) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (MACIN(1),NBIN(1)) C C *ENTRY PARAMETERS C IN - MACRO DIRECTIVE LINE C MSREC - NEXT AVAILABLE RECORD IN MACRO DISK FILE C C *EXIT PARAMETERS C MACRO DEFINITION ON DISK FILE C MDISK - CONTAINS STARTING RECORD NUMBER OF MACRO C IEND - SET TO 1 IF END FOUND DURING MACRO C ICHK = 0 IEND = 0 IPCNT = 1 MDISK(MCNT) = MSREC NERR = 0 MCALL(82,1) = ISHRP MCALL(83,1) = IDOLR MCALL(84,1) = ICHRY MCALL(85,1) = ICHRM MPARP(1,IPCNT) = 82 MPARP(2,IPCNT) = 85 DO 5 LL=1,80 MACIN(LL) = IN(LL) MCALL(LL,1) = IN(LL) 5 CONTINUE C SCAN PROTOTYPE LINE FOR PARAMETERS AND FORM PARAMETER TABLE 20 IF(IARG-MCOL) 30,30,130 30 ICOL = IARG 40 IF(IN(ICOL)-ISEMI) 100,130,100 100 IF(IN(ICOL)-ISHRP) 920,110,920 110 ICOL1 = ICOL ICOL = ICOL+1 CALL SYMBL(ICOL) IF(IERR-3) 120,920,920 C FOUND VALID PARAMETER, SAVE IN TABLE 120 IPCNT = IPCNT+1 MPARP(1,IPCNT) = ICOL1 MPARP(2,IPCNT) = ICOL-1 ICOL = ICOL+1 IF(IERR-2) 130,100,130 130 MPARC(MCNT) = IPCNT GO TO 550 C READ NEXT MODEL STATEMENT AND CHECK FOR PARAMETERS C SUBSTITUTE A PARAMETER MARKER TO INDICATE RELATIVE C POSITION OF PARAMETER FOR MACRO REFERENCE 200 CALL INOUT(1) ITYPE = -1 IERR = 1 IERRI(1) = IBLNK IERRI(2) = IBLNK IERRI(3) = IBLNK IERRI(4) = 0 NERR = 0 DO 210 LL=1,80 MACIN(LL) = IN(LL) 210 CONTINUE DO 360 LL=IFCOL,MCOL IF(MACIN(LL)-ISHRP) 360,310,360 C CHECK IF VALID PARAMETER 310 DO 350 IPC = 1,IPCNT ICOL = MPARP(1,IPC) ICOL1 = MPARP(2,IPC) IF((LL+ICOL1-ICOL)-MCOL) 320,320,350 320 L = LL DO 330 K=ICOL,ICOL1 IF(MACIN(L)-MCALL(K,1)) 350,325,350 325 L = L+1 330 CONTINUE C VALID PARAMETER, PUT IN MARKER L = LL DO 340 K=ICOL,ICOL1 MACIN(L) = IPC L = L+1 340 CONTINUE 350 CONTINUE 360 CONTINUE C GET OPCODE TO CHECK FOR END OR ENDM ICOL = IFCOL IF(IN(ICOL)-IBLNK) 400,450,400 400 IF(IN(ICOL)-IAST) 410,500,410 410 IF(IN(ICOL)-ICTAB) 420,450,420 C SKIP OVER LABEL FIELD 420 ICOL = ICOL+1 IF(IN(ICOL)-IBLNK) 425,470,425 425 IF(IN(ICOL)-ICTAB) 430,470,430 430 IF(IN(ICOL)-ICOLN) 440,470,440 440 IF(ICOL-MCOL) 420,500,500 450 CALL OPCOD(ICOL,ICHK) IF(IERR-6) 500,460,500 460 ICOL = ICOL+ICNT 470 ICOL = ICOL+1 CALL OPCOD(ICOL,ICHK) C C THE FOLLOWING STATEMENT WRITES INTO THE MACRO SOURCE FILE C 500 MCREC = MSREC MSREC = MSREC+1 CALL INOUT(6) C WRITE STATEMENT TO INTERMEDIATE FILE FOR USE BY PASS 2 C SET LINE SO THAT IT LOOKS LIKE A COMMENT FOR PRINTOUT 550 ITYPE = -1 IERRI(4) = NERR LEN = 0 IMREC = ISN ISN = ISN+1 CALL INOUT(5) LISN = LISN+1 C CHECK FOR ENDM OR END INSTRUCTIONS IF(ICHK-1017) 570,590,570 570 IF(ICHK-1006) 200,580,200 580 IEND = 1 590 RETURN C ILLEGAL PARAMETER LIST 920 IERRI(2) = ICHRA IERRS = IERRS+1 IERRI(4) = 1 NERR = 1 GO TO 130 END SUBROUTINE MCREF C C C THIS SUBROUTINE IS USED TO EXPAND A MACRO WHENEVER THERE IS A C REFERENCE TO IT. REPLACE PARAMETERS BY ACTUAL CHARACTERS OF C CALL PARAMETERS. THUS TO PASS 1 IT LOOKS AS THOUGH C IT IS JUST READING IN ANOTHER CARD C C REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION MACIN(80) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (MACIN(1),NBIN(1)) C C *ENTRY PARAMETERS C MCREC - DISK RECORD NUMBER OF NEXT MACRO DEFINITON LINE C C *EXIT PARAMETERS C MCREC - SET TO NEXT RECORD C IN - LINE SET TO PROCESS WITH MACRO PARAMETERS C REPLACED BY ACTUAL PARAMETERS C NREC = MCREC 100 INPNT = 1 MCPNT = 1 C C THE FOLLOWING STATEMENT READS FROM THE MACRO SOURCE FILE. C CALL INOUT(3) NREC = NREC+1 MCREC = NREC DO 105 LL=1,80 IN(LL) = MACIN(LL) 105 CONTINUE C PLACE ARGUMENTS FROM MACRO CALL INTO MODEL STATEMENTS AND C INTO INPUT BUFFER TO BE USED BY PASS 1 110 IF(MACIN(MCPNT)-100) 115,140,140 115 IF(MACIN(MCPNT)) 140,112,112 112 ISAVE = MACIN(MCPNT) C GET PARAMETER NUMBER IPARN = ISAVE+MPCNT IF(IPARN-MXPAR) 118,118,117 117 IPARN = 1 118 ISTA = MPARP(1,IPARN) IFIN = MPARP(2,IPARN) IF(ISTA-IFIN) 119,119,130 119 IF((INPNT+IFIN-ISTA)-MCOL) 120,120,910 C SUBSTITUTE ACTUAL PARAMETER FOR PARAMETER MARKERS 120 DO 122 KK=ISTA,IFIN IN(INPNT) = MCALL(KK,MCSET) INPNT = INPNT+1 122 CONTINUE C SCAN OVER PARAMETER MARKER 130 MCPNT = MCPNT+1 IF(MACIN(MCPNT)-ISAVE) 110,130,110 140 IN(INPNT) = MACIN(MCPNT) IF(INPNT-80) 142,170,170 142 IF(MCPNT-80) 144,150,150 144 INPNT = INPNT+1 MCPNT = MCPNT+1 GO TO 110 150 ISTA = INPNT+1 DO 160 INPNT = ISTA,80 IN(INPNT) = IBLNK 160 CONTINUE C MODEL STATEMENT NOW LOOKS LIKE A STANDARD LINE AND CAN C BE PROCESSED BY PASS 1 170 RETURN C INSERTION OF PARAMETERS TOO LONG FOR CARD IMAGE 910 IERRI(2) = ICHRC IERRI(4) = 1 IERRS = IERRS+1 RETURN END SUBROUTINE LOUT(MODE) C C C THIS SUBROUTINE IS USED TO OUTPUT THE ASSEMBLER LISTING C C INTEGER OBIN(2,4) REAL IVAL REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION NUMS(16) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (NUMS(1),IALPH(1)) C C *ENTRY PARAMETERS C LISN - LINE NUMBER C MODE - INDICATES WHETHER REGULAR LINE OR DIRECTIVE C 1 = NORMAL LINE C 2 = NOT USED C 3 = SPAC DIRECTIVE C 4 = EJEC DIRECTIVE C C *EXIT PARAMETERS C LISN - UPDATED LINE NUMBER C LISN = LISN+1 C CONVERT VALUES TO HEXADECIMAL FOR OUTPUT DO 30 J=1,4 IF(J-LLEN) 10,10,20 10 NVAL = IBIN(J) CALL VHEX(NVAL,NH1,NH2) OBIN(1,J) = NH1 OBIN(2,J) = NH2 GO TO 30 20 OBIN(1,J) = IBLNK OBIN(2,J) = IBLNK 30 CONTINUE IMACP = IBLNK IEQUI = IBLNK IF(MAC-2) 50,40,50 40 IMACP = IPLUS LISN = LISN-1 C CHECK FOR AN ERROR 50 IF(IERRI(4)) 60,60,200 60 IF(LSOR) 700,700,100 100 IF(MAC-1) 110,200,110 C CHECK FOR OUTPUT OF MACRO EXPANSION 110 IF(LMAC) 200,700,200 C CHECK OUTPUT LINE COUNT 200 LINE = LINE+1 IF(LINE-IOLIN) 400,400,210 C EJECT TO NEXT PAGE AND WRITE HEADER 210 WRITE(IPRT,1001) (LTITL(I),I=1,28),IPAGE 1001 FORMAT(34H1 MOSTEK XFOR-80 CROSS ASSEMBLER,1X,28A1,5H PAGE,I4, 1 /,44H ADDR OBJECT STMT LABEL OPCD OPERAND, 2 6X,7HCOMMENT,/) IPAGE = IPAGE+1 LINE = 4 400 GO TO (410,410,600,700),MODE C LEAVE ADDRESS BLANK IF TYPE = -1 EXCEPT FOR EQU OR DEFL 410 IF(ITYPE) 420,440,440 420 IF(IOPVA-100) 460,430,460 430 IEQUI = IGRAT IVAL = IPVAL GO TO 450 440 IVAL = LC 450 CALL AHEX(IVAL,1) GO TO 500 460 DO 470 J=1,4 IADDR(1,J) = IBLNK 470 CONTINUE 500 CALL FORMT WRITE(IPRT,1002) IERRI(1),IERRI(2),IEQUI,(IADDR(1,J),J=1,4), 1 (OBIN(1,J),OBIN(2,J),J=1,4),LISN,IMACP,(IN(J),J=1,MLCOL) 1002 FORMAT(1X,7A1,1X,8A1,1X,I4,1X,81A1) RETURN C PROCESS SPAC DIRECTIVE 600 LINE = LINE+1 IF(LINE-IOLIN) 610,610,200 610 WRITE(IPRT,1003) 1003 FORMAT(1X) IARG = IARG-1 IF(IARG) 700,700,600 700 RETURN END SUBROUTINE OUT C C C THIS SUBROUTINE OUTPUTS THE OBJECT MODULE PRODUCED BY THE C EACH CARD CONTAINS A RECORD LENGTH OF UP TO 30 BYTES C C REAL LC,LODLC,IPVAL,ITABV(200) REAL IVAL DIMENSION NUMS(16) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (NUMS(1),IALPH(1)) C C *ENTRY PARAMETERS C LOBJ - 0 = DO NOT FORM OBJECT MODULE C LC - ADDRESS OF INSTRUCTION C LODLC - ADDRESS OF LAST OBJECT BYTE PROCESSED C IBIN - OBJECT CODE TO PLACE IN OBJECT MODULE C C *EXIT PARAMETERS C IOBIN - PARTIAL OBJCT MODULE RECORD C LODLC - UPDATED TO ADDRESS OF LAST BYTE PROCESSED C IF(LOBJ) 120,120,10 10 N = 1 C CHECK FOR GAP IN LOCATION COUNTER 50 IF(LC-LODLC) 60,90,60 60 IF(LODLC) 70,80,80 70 LODLC = LC GO TO 300 80 LODLC = LC GO TO 200 C CHECK FOR END OF ASSEMBLY 90 IF(IEND) 100,100,200 C SET BYTES OF OBJECT CODE INTO HEXADECIMAL OUTPUT RECORD C CHECK FOR MAXIMUM RECORD SIZE 100 IF(IRLEN-30) 110,200,200 110 NN = IBIN(N) ICKSM = ICKSM+NN IRLEN = IRLEN+1 CALL VHEX(NN,NH1,NH2) IOBIN(ICNT) = NH1 ICNT = ICNT+1 IOBIN(ICNT) = NH2 ICNT = ICNT+1 LODLC = LODLC+1. N = N+1 IF(N-LLEN) 100,100,120 120 RETURN C SET RECORD LENGTH AND OUTPUT NEW RECORD 200 CALL VHEX(IRLEN,NH1,NH2) ICKSM = ICKSM+IRLEN IOBIN(2) = NH1 IOBIN(3) = NH2 C SET CHECKSUM J = ICKSM/256 ICKSM = 256-(ICKSM-J*256) CALL VHEX(ICKSM,NH1,NH2) IOBIN(ICNT) = NH1 ICNT = ICNT+1 IOBIN(ICNT) = NH2 WRITE(IPCH,1000) (IOBIN(J),J=1,ICNT) 1000 FORMAT(72A1) C INITIALIZE FOR NEXT RECORD 300 ICKSM = 0 IRLEN = 0 ICNT = 10 DO 350 J=1,72 IOBIN(J) = IBLNK 350 CONTINUE C INITIALIZE COLON INDICATING START OF RECORD IOBIN(1) = ICOLN C CHECK FOR END CARD IF(IEND) 410,410,400 C SET ADDRESS INTO RECORD 400 LODLC = IPVAL 410 NN = LODLC/256. ICKSM = ICKSM+NN CALL VHEX(NN,NH1,NH2) IOBIN(4) = NH1 IOBIN(5) = NH2 IVAL = NN NN = LODLC-IVAL*256. ICKSM = ICKSM+NN CALL VHEX(NN,NH1,NH2) IOBIN(6) = NH1 IOBIN(7) = NH2 IOBIN(8) = NUMS(1) IOBIN(9) = NUMS(1) IF(IEND) 100,100,700 C PUT OUT RECORD TO INDICATE END OF FILE 700 IOBIN(2) = NUMS(1) IOBIN(3) = NUMS(1) IOBIN(9) = NUMS(2) ICKSM = ICKSM+1 J = ICKSM/256 ICKSM = 256-(ICKSM-J*256) CALL VHEX(ICKSM,NH1,NH2) IOBIN(10) = NH1 IOBIN(11 )= NH2 WRITE(IPCH,1000) (IOBIN(J),J=1,11) RETURN END SUBROUTINE SYMTA C C C THIS SUBROUTINE IS USED TO OUTPUT A SYMBOL TABLE C OR CROSS REFERENCE TABLE C C REAL LC,LODLC,IPVAL,ITABV(200) REAL IVAL DIMENSION LLAB(4,6),IXOUT(600) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (LLAB(1,1),IN(1)) EQUIVALENCE(IXOUT(1),MDISK(1)) C C *ENTRY PARAMETERS C LREF - 1 = PRODUCE CROSS REFERENCE TABLE C IXT - NEGATIVE IF CROSS REFERENCE TABLE OVERFLOWED C IDIV = 256**(ICCNT-1) MXLAB = 42*IDIV ISTA = 1 IFIN = 1 IGX = 0 IF(LREF) 8,8,6 6 IF(IXT) 7,8,8 7 IXT = -IXT WRITE(IPRT,1010) IXT 1010 FORMAT(34H CROSS REFERENCE OVERFLOW AT LINE ,I5) LINE = 8 IXT = 0 8 DO 70 L=1,LTAB IF(ITAB(1,L)) 10,70,10 10 IF(ISTA) 30,20,30 20 ISTA = L 30 IFIN = L 70 CONTINUE C ALPHABETIZE AND OUTPUT SYMBOLS 140 MM = 0 145 NAME(1) = MXLAB C GET NEXT SYMBOL LIND = 0 DO 260 L=ISTA,IFIN IF(ITAB(1,L)) 210,260,210 210 DO 230 K=1,IWORD IF(ITAB(K,L)-NAME(K)) 240,230,260 230 CONTINUE 240 DO 250 K=1,IWORD NAME(K) = ITAB(K,L) 250 CONTINUE LIND = L 260 CONTINUE IF(LIND) 300,270,300 270 IF(MM) 430,430,400 300 ITAB(1,LIND) = 0 MM = MM+1 ICNT = 0 C DECODE VALUE IN TABLE TO FORM OUTPUT CHARACTERS DO 310 K=1,IWORD ID = IDIV DO 310 L=1,ICCNT ICNT = ICNT+1 NN = NAME(K)/ID IF(NN) 312,312,314 312 LLAB(MM,ICNT) = IBLNK IF (ICNT-MLAB) 316,315,315 314 NAME(K) = NAME(K)-NN*ID LLAB(MM,ICNT) = IALPH(NN) 316 ID = ID/256 310 CONTINUE C GET SYMBOL VALUE 315 IVAL = ITABV(LIND) IF(IVAL-100000.) 330,330,320 320 IVAL = IVAL-100000. 330 CALL AHEX(IVAL,MM) IF(LREF) 340,340,500 340 IF(MM-4) 145,400,400 400 LINE = LINE+1 IF(LINE-IOLIN) 420,420,410 410 WRITE(IPRT,1002) 1002 FORMAT(1H1) LINE = 3 C OUTPUT NEXT LINE OF SYMBOL TABLE 420 WRITE(IPRT,1003) ((LLAB(II,K),K=1,ICNT), 1 (IADDR(II,L),L=1,4), II=1,MM) 1003 FORMAT(1X,4(6A1,2X,4A1,6X)) IF(LIND) 430,430,140 430 RETURN C FORM CROSS REFERENCE TABLE C WRITE LAST RECORD TO FILE IF NECESSARY 500 IF(IGX) 530,510,530 510 IF(IXPNT) 530,530,515 515 IF(IXCNT) 530,530,520 520 CALL XREFT(1,1) 530 IGX = 1 LEN = 0 IXOUT(1) = 0 ITCNT = MXREF*IXCNT+IXPNT IF(ITCNT-MXREF) 580,580,540 C READ PAGE FROM FILE 540 IXT = 1 550 L = MXREF/128 I1 = 0 DO 570 I=1,L MCREC = IXT C C THE FOLLOWING STATEMENTS READS THE CROSS REFERENCE FILE C CALL INOUT(4) IXT = IXT+1 DO 560 M1=1,128 M2 = M1+I1 IXTAB(M2) = MCORE(M1) 560 CONTINUE I1 = I1+128 570 CONTINUE 580 LL = MXREF IF(ITCNT-MXREF) 590,600,600 590 LL = ITCNT 600 DO 620 I=1,LL,2 IF(IXTAB(I)-LIND) 620,610,620 610 LEN = LEN+1 I1 = I+1 IXOUT(LEN) = IXTAB(I1) 620 CONTINUE ITCNT = ITCNT-MXREF IF(ITCNT) 630,630,550 C OUTPUT CROSS REFERENCES 630 M1 = 1 640 M2 = M1+7 IF(LEN-8) 650,660,660 650 M2 = M1+LEN-1 660 LINE = LINE+1 IF(LINE-IOLIN) 680,670,670 670 WRITE(IPRT,1002) LINE = 3 680 WRITE(IPRT,1005) (LLAB(1,K),K=1,ICNT),(IADDR(1,K),K=1,4), 1 (IXOUT(K),K=M1,M2) 1005 FORMAT(1X,6A1,4X,4A1,6X,8I6) M1 = M1+8 LEN = LEN-8 IF(LEN) 140,140,690 690 DO 700 K=1,4 IADDR(1,K) = IBLNK LLAB(1,K) = IBLNK 700 CONTINUE LLAB(1,5)=IBLNK LLAB(1,6)=IBLNK GO TO 640 END SUBROUTINE XREFT(MODE,NCTL) C C THIS SUBROUTINE ACCUMULATES CROSS REFERENCES C REAL LC,LODLC,IPVAL,ITABV(200) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) C *ENTRY PARAMETERS C MODE - INDICATES DEFINITION (0), OR REFERENCE (1) C NCTL - 1 INDICATES DO ONLY WRITE TO DISK C IXPNT - CURRENT POINTER INTO REFERENCE TABLE C C *EXIT PARAMETERS C IXPNT - UPDATED FOR NEW ENTRY IN TABLE C IXCNT - INCREMENTED BY ONE IF REFERENCE ARRAY IS FULL C IF(NCTL) 5,5,50 5 IF(IXT) 110,10,10 10 IF(IXPNT-MXREF) 100,30,30 30 IF(IXCNT-IXPAG) 50,40,40 40 IXT = -(LISN+MODE) RETURN C WRITE OUT PAGE TO FILE 50 K = MXREF/128 I1 = 0 DO 70 I=1,K DO 60 M1 = 1,128 M2 = I1+M1 IXTAB(M1) = IXTAB(M2) 60 CONTINUE MCREC = IXT C C THE CROSS REFERENCE FILE IS WRITTEN INTO BY C THE FOLLOWING STATEMENT C CALL INOUT(7) I1 = I1+128 IXT = IXT+1 70 CONTINUE IF(NCTL) 80,80,110 80 IXCNT = IXCNT+1 IXPNT = 0 IF(IXCNT-IXPAG) 100,40,40 C PUT DEFINITION OR REFERENCE IN TABLE 100 IXPNT = IXPNT+1 IXTAB(IXPNT) = INDEX IXPNT = IXPNT+1 IXTAB(IXPNT) = (LISN+MODE)*(MODE+MODE-1) 110 RETURN END SUBROUTINE VHEX(NVAL,NH1,NH2) C C C THIS ROUTINE CONVERTS A VALUE BETWEEN 0 - 255 TO TWO C HEXADECIMAL CHARACTERS. VALUES OUTSIDE THIS RANGE ARE C CONVERTED TO ZEROS C C REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION NUMS(16) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE(NUMS(1),IALPH(1)) C C C *ENTRY PARAMETERS C NVAL - VALUE TO CONVERT C C *EXIT PARAEMTERS C NH1 - HIGH ORDER CHARACTER ON RETURN C NH2 - LOW ORDER CHARACTER ON RETURN C IF(NVAL-256) 10,30,30 10 IF(NVAL) 30,100,100 30 NVAL = 0 100 NH1 = 1+NVAL/16 NH2 = NVAL-(NH1-1)*16+1 NH1 = NUMS(NH1) NH2 = NUMS(NH2) RETURN END SUBROUTINE AHEX(IVAL,INDX) C C C THIS SUBROUTINE CONVERTS A VALUE BETWEEN 0 -65535 INTO 4 C HEXADECIMAL CHARACTERS. VALUES OUTSIDE THIS RANGE ARE RETURNED C AS ASTERISKS C C REAL LC,LODLC,IPVAL,ITABV(200) REAL IVAL,IHVAL,J1,IVAL2 DIMENSION NUMS(16) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (NUMS(1),IALPH(1)) C C *ENTRY PARAMETERS C IVAL - VALUE TO CONVERT C INDX - INDEX FOR STORAGE OF OUTPUT C C *EXIT PARAMETERS C IADDR - IADDR(INDX,1-4) CONTAINS CHARACTERS C J1 = 4096. IF(IVAL) 20,5,5 5 IF(IVAL-65536.) 10,20,20 10 IHVAL = IVAL DO 15 J=1,4 M1 = IHVAL/J1 IVAL2 = M1 IHVAL = IHVAL-IVAL2*J1 J1 = J1/16. M1 = M1+1 IADDR(INDX,J) = NUMS(M1) 15 CONTINUE RETURN 20 DO 25 J=1,4 IADDR(INDX,J) = IAST 25 CONTINUE RETURN END SUBROUTINE OPRND(ICOL,IVAL) C C THIS ROUTINE IS USED TO OBTAIN THE ARGUMENTS OR OPERANDS C FOR THE VARIOUS OPCODES. AN OPERAND IS EITHER AN ASSEMBLER C DEFINED KEYWORD, AN IMMEDIATE OR ADDRESS VALUE. C REAL IVAL REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION KEYIF(35),KEYWD(35) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) C C SET DATA ARRAY FOR ENCODED KEYWORD AND KEYWORD C VALUE,TYPE AND PARENTHESIS INDICATOR. C DATA KEYWD( 1),KEYWD( 2),KEYWD( 3),KEYWD( 4) /4630,2816,3072,3328/ DATA KEYWD( 5),KEYWD( 6),KEYWD( 7),KEYWD( 8) /3584,3840,0,0/ DATA KEYWD( 9),KEYWD(10),KEYWD(11),KEYWD(12) /4608,4864,0,0/ DATA KEYWD(13),KEYWD(14),KEYWD(15),KEYWD(16) /5632,4898,4899,7450/ DATA KEYWD(17),KEYWD(18),KEYWD(19),KEYWD(20) /0,3085,7168,2832/ DATA KEYWD(21),KEYWD(22),KEYWD(23),KEYWD(24) /0,3599,4898,0/ DATA KEYWD(25),KEYWD(26),KEYWD(27),KEYWD(28) /6681,9216,6157,4899/ DATA KEYWD(29),KEYWD(30),KEYWD(31),KEYWD(32) /5888,4630,6671,6656/ DATA KEYWD(33),KEYWD(34),KEYWD(35) /0,6180,3328/ DATA KEYIF( 1),KEYIF( 2),KEYIF( 3),KEYIF( 4) /282,452,4,70/ DATA KEYIF( 5),KEYIF( 6),KEYIF( 7),KEYIF( 8) /132,196,0,0/ DATA KEYIF( 9),KEYIF(10),KEYIF(11),KEYIF(12) /260,524,0,0/ DATA KEYIF(13),KEYIF(14),KEYIF(15),KEYIF(16) /324,14170,16218,410/ DATA KEYIF(17),KEYIF(18),KEYIF(19),KEYIF(20) /0,26,1036,412/ DATA KEYIF(21),KEYIF(22),KEYIF(23),KEYIF(24) /0,154,14153,0/ DATA KEYIF(25),KEYIF(26),KEYIF(27),KEYIF(28) /2080,540,1052,16201/ DATA KEYIF(29),KEYIF(30),KEYIF(31),KEYIF(32) /3616,389,2592,3104/ DATA KEYIF(33),KEYIF(34),KEYIF(35) /0,28,1564/ C C * ENTRY PARAMETERS C NJMP - OPCODE TYPE C 0 = CALL, JUMP AND RETURN INSTRUCTIONS C 1 = ALL OTHERS C ICOL - STARTING COLUMN OF SCAN C C * EXIT PARAMETERS C ICOL - FINAL COLUMN OF SCAN C KWTYP - TYPE OF OPERAND C 1 = A,B,C,D,E,H,L(HL) C 2 = (IX+D),(IY+D) C 3 = (SP),(BC),(DE),I,R C 4 = N,NN (IMMEDIATE VALUE) C 5 = (NN) (ADDRESS VALUE) C 6 = BC,DE,HL,IX,IY,SP C 7 = AF,AF",C,NC,Z,NZ C 8 = M,P,PE,PO,(C) C KWVAL - VALUE OF OPERAND C KWIND - INDEX OF KEYWORD IN TABLE, FORMED BY HASH CODE C IVAL - VALUE FOR 4 OR 5 ABOVE C IERR - ERROR CODE, SAME AS FROM SUBROUTINE SCAN C EXCEPT FOR 6 = KEYWORD ERROR C C IVAL = 0 LPAR = 0 KWTYP = 0 KWIND = 0 KWVAL = 0 ICOL1 = ICOL IF(IN(ICOL)-ILPAR) 20,10,20 C SET LEADING PARENTHESIS FLAG 10 LPAR = 1 ICOL = ICOL+1 C GET AND CHECK FOR KEYWORD 20 CALL SYMBL(ICOL) NDIV=256**(ICCNT-2) NAME(1)=NAME(1)/NDIV IF(IERR-4) 30,500,500 C VALID SYMBOL CHECK LENGTH 30 IF(LABCT-2) 40,40,500 C FORM INDEX INTO KEYWORD TABLE AND CHECK VALIDITY 40 NSYSM = INDEX IF(NJMP) 80,80,50 50 KWIND = NSYSM+LABCT+LABCT-11 IF(KWIND-32) 70,70,60 60 KWIND = KWIND-32 70 IF(KWIND-22) 120,120,500 80 IF(NSYSM-53) 100,90,100 90 NSYSM = 49 100 KWIND = 22+NSYSM-(NSYSM/16)*16 IF(KWIND-35) 110,110,500 110 IF(KWIND-22) 500,500,120 C CHECK TABLE ENTRY 120 IF(NAME(1)-KEYWD(KWIND)) 500,200,500 C VALID KEYWORD - GET KEYWORD PARAMETERS 200 KWPAR = KEYIF(KWIND) KWVAL = KWPAR/64 KWTYP = (KWPAR-KWVAL*64)/4 KWPAR = KWPAR-KWVAL*64-KWTYP*4 IF(LPAR) 210,210,300 C NO LEADING PARENTHESIS, CHECK IF PARENTHESIS REQUIRED 210 IF(KWPAR-1) 220,900,220 C CHECK IF AF" 220 IF(KWIND-20) 610,230,610 230 IF(IN(ICOL)-IQUOT) 610,240,610 240 KWIND = 17 KWVAL = 10 GO TO 600 C LEADING PARENTHESIS, CHECK IF PARENTHESIS NOT ALLOWED 300 IF(KWPAR) 900,900,310 310 IF(IN(ICOL)-IRPAR) 400,320,400 320 IF(NJMP) 600,600,330 C CHECK FOR (C) 330 KWTYP = 8 IF(KWIND-4) 340,600,340 C FORM SPECIAL KEYWORD TYPE - (HL),2,3 340 KWTYP = 3 IF(KWIND-16) 350,600,600 C CHECK IF (IX),(IY) 350 KWTYP = 2 IVAL = 0 IF(KWIND-14) 360,900,900 C SET TO (HL) 360 KWTYP = 1 KWVAL = 6 GO TO 600 C CHECK FOR (IX+D),(IY+D) 400 KWTYP = 2 IF(NJMP) 900,900,410 410 IF(KWVAL-200) 900,900,420 420 IF(IN(ICOL)-IPLUS) 430,440,430 430 IF(IN(ICOL)-IMIN) 900,440,900 C SET PARENTHESIS FLAG FOR SCAN ROUTINE 440 NSPAR = 1 GO TO 510 C GET VALUE FOR INDEXING,IMMEDIATE OR EXTENDED ADDRESSING 500 ICOL = ICOL1 510 CALL SCAN(ICOL,IVAL) GO TO(520,1000,520,520,1000),IERR 520 IF(KWTYP-2) 530,1000,530 C SET TYPE TO IMMEDIATE OR EXTENDED 530 KWTYP = 4+LPAR GO TO 1000 C CHECK THAT OPERAND ENDS WITH VALID DELIMITER 600 ICOL = ICOL+1 610 NCHAR = IN(ICOL) IERR = 1 IF(NCHAR-IBLNK) 620,1000,620 620 IF(NCHAR-ICOMM) 630,910,630 630 IF(NCHAR-ISEMI) 640,1000,640 640 IF(NCHAR-ICTAB) 900,1000,900 C SET ERROR RETURN FLAG C INVALID KEYWORD OR KEYWORD SYNTAX 900 IERR = 6 GO TO 1000 C COMMA TERMINATES OPERAND 910 IERR = 4 1000 RETURN END SUBROUTINE CODEZ(ICOL) C C THIS ROUTINE PROCESSES THE OPCODES FOR THE Z-80 C REAL IVAL,IVAL1 REAL LC,LODLC,IPVAL,ITABV(200) DIMENSION IEXV(5),IEXVI(5) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (IBIN(1),IBIN1) EQUIVALENCE (IBIN(2),IBIN2) EQUIVALENCE (IBIN(3),IBIN3) EQUIVALENCE (IBIN(4),IBIN4) DATA IEXV(1),IEXV(2),IEXV(3),IEXV(4),IEXV(5) /2724,2807,1907, 1 1920,1921/ DATA IEXVI(1),IEXVI(2),IEXVI(3),IEXVI(4),IEXVI(5) 1 /8,235,227,221,253/ C C * ENTRY PARAMETERS C ICOL - STARTING COLUMN OF SCAN C ITYPE - INSTRUCTION TYPE FROM OPCOD C C * EXIT PARAMETERS C ICOL - FINAL COLUMN OF SCAN C LEN - LENGTH OF INSTRUCTION (BYTES) C IBIN - CONTAINS VALUE OF INSTRUCTION C IERR - ERROR CODE - SAME AS FOR OPROD EXCEPT C 7 = QUESTIONABLE OPERANDS, 8 = VALUE ERROR C IERR = 1 IERR1 = 1 LEN = 4 IF(ITYPE-4) 8400,8150,4000 4000 NJMP = 0 KWCNT = 0 C CHECK FOR RET INSTRUCTION AND 1 OR 2 OPERAND INSTRUCTIONS IF(ITYPE-16) 4010,6650,4020 4010 NJMP = 1 4020 CALL OPRND(ICOL,IVAL) GO TO (4030,9000,4030,4030,9000,9000),IERR 4030 IF(ITYPE-9) 4080,4080,4040 C CHECK IF ADDITIONAL ARGUMENTS 4040 IF(ITYPE-16) 4060,4080,4050 4050 IF(IN(ICOL)-ICOMM) 4080,4070,4080 4060 NN = 2 IF(IN(ICOL)-ICOMM) 9430,4070,9430 C GET NEXT OPERAND AND SAVE CURRENT PARAMETERS 4070 ICOL = ICOL+1 KWTY1 = KWTYP KWVA1 = KWVAL IVAL1 = IVAL KWIN1 = KWIND KWCNT = 1 IERR1 = IERR CALL OPRND(ICOL,IVAL) GO TO (4080,9000,4080,4080,9000,9000),IERR C PROCESS INSTRUCTIONS ACCORDING TO OPCODE 4080 KTYPE = ITYPE-4 GO TO(4100,4200,4300,4400,4600,4700,6000,6100,6200, 1 6400,6500,6600,6700,6800,6900),KTYPE C C PROCESS RST,IM C 4100 LEN = 1 IF(KWTYP-4) 9150,4105,9150 4105 IF(IOPVA-70) 4110,4150,4110 4110 K = IVAL/8. IVAL1 = K I = IVAL-IVAL1*8. IF(I) 9350,4120,9350 4120 IF(K) 9350,4130,4130 4130 IF(K-8) 4140,9350,4140 4140 IBIN1 = IOPVA+K*8 GO TO 8400 C IM 4150 LEN = 2 IBIN2 = 70 IF(IVAL) 9350,8160,4160 4160 IBIN2 = 86 IF(IVAL-2.) 8160,4170,9350 4170 IBIN2 = 94 GO TO 8160 C C PROCESS DJNZ C 4200 IBIN1 = 16 GO TO 8000 C C PROCESS ROTATE AND SHIFT INSTRUCTIONS 4300 IVAL1 = 0 GO TO 6110 C C PROCESS SUB,AND,XOR,OR,CP,INC,DEC 4400 IF(KWTYP-2) 4410,4420,4430 C REGISTER ADDRESSING 4410 IBIN1 = IOPVA+KWVAL C CHECK IF INC,DEC IF(IOPVA-5) 4630,4630,8400 C INDEXED ADDRESSING 4420 IBIN2 = IOPVA+6 IF(IOPVA-5) 4425,4425,8100 4425 IBIN2 = IOPVA+48 GO TO 8100 4430 IF(KWTYP-4) 9100,4440,4460 C IMMEDIATE ADDRESSING - CHECK IF INC,DEC 4440 IF(IOPVA-5) 9100,9100,4450 4450 IBIN1 = IOPVA+70 GO TO 8200 C CHECK FOR 16 BIT INC,DEC 4460 IF(IOPVA-5) 4470,4470,9100 4470 IF(KWTYP-6) 9100,4480,9100 4480 IF(KWVAL-200) 4490,4500,4500 C SOURCE IS BC,DE,HL 4490 IBIN1 = (IOPVA+KWVAL)*8-29 GO TO 8400 C SOURCE IS IX,IY 4500 IBIN2 = IOPVA*8+3 GO TO 8050 C C PROCESS POP,PUSH C 4600 IF(KWTYP-6) 9100,4610,4610 4610 IF(KWIND-16) 4620,9100,4620 4620 IF(KWVAL-10) 4630,9100,4640 C SOURCE IS AF,BC,DE,HL 4630 IBIN1 = IOPVA+8*KWVAL GO TO 8400 C SOURCE IS IX,IY 4640 IBIN2 = IOPVA+32 GO TO 8050 C C PROCESS LD C 4700 GO TO(4800,5000,5200,9100,5400,5600,9100),KWTY1 C *** DESTINATION IS A-L,(HL) 4800 GO TO(4820,4840,4860,4900,4920,9100,9100,9100),KWTYP C SOURCE IS A-L,(HL) 4820 LEN = 1 IBIN1 = 64+8*KWVA1+KWVAL C CHECK FOR LD (HL),(HL) IF(IBIN1-118) 9000,9150,9000 C SOURCE IS INDEXED 4840 IBIN2 = 70+8*KWVA1 GO TO 5020 C SOURCE IS (BC),(DE),I,R - CHECK A IS DESTINATION 4860 IF(KWVA1-7) 9100,4870,9100 4870 IF(KWVAL-6) 4880,9100,4890 4880 IBIN1 = 10+KWVAL*8 GO TO 8400 C SOURCE IS I,R 4890 IBIN2 = 79+KWVAL GO TO 8160 C SOURCE IS IMMEDIATE BYTE 4900 IBIN1 = 6+8*KWVA1 GO TO 8200 C SOURCE IS EXTENDED ADDRESS - CHECK A IS DESTINATION 4920 IBIN1 = 58 IF(KWVA1-7) 9100,8250,9100 C *** DESTINATION IS INDEXED 5000 IF(KWTYP-1) 9100,5010,5050 C SOURCE IS A-L 5010 IBIN2 = 112+KWVAL KWVAL = KWVA1 IVAL = IVAL1 5020 IF(IBIN2-118) 8100,9100,8100 5050 IF(KWTYP-4) 9100,5060,9100 C SOURCE IS IMMEDIATE BYTE 5060 LEN = 4 IBIN1 = KWVA1 IBIN2 = 54 IF (IVAL-256.) 5090,5070,5070 5070 IF (IVAL-65280.) 9350,5080,5080 5080 IVAL=IVAL-65280. 5090 IBIN4 = IVAL IVAL = IVAL1 GO TO 8105 C *** DESTINATION IS (BC),(DE),I,R - CHECK A IS DESTINATION 5200 IF(KWIND-2) 9100,5210,9100 5210 IF(KWVA1-6) 5220,9100,5230 5220 IBIN1 = 2+KWVA1*8 GO TO 8400 C DESTINATION IS I,R 5230 IBIN2 = 63+KWVA1 GO TO 8160 C *** DESTINATION IS EXTENDED ADDRESS 5400 IVAL = IVAL1 IF(KWIND-2) 5420,5410,5420 C SOURCE IS A 5410 IBIN1 = 50 GO TO 8250 5420 IF(KWTYP-6) 9100,5430,9100 5430 IF(KWVAL-4) 5450,5460,5440 5440 IF(KWVAL-6) 5450,5450,5470 C SOURCE IS BC,DE,SP 5450 IBIN1 = 237 IBIN2 = 67+KWVAL*8 GO TO 8310 C SOURCE IS HL 5460 IBIN1 = 34 GO TO 8300 C SOURCE IS IX,IY 5470 IBIN1 = KWVAL IBIN2 = 34 GO TO 8310 C *** DESTINATION IS BC,DE,HL,SP,IX,IY 5600 IF(KWTYP-4) 9100,5620,5610 5610 IF(KWTYP-6) 5700,5800,9100 C SOURCE IS IMMEDIATE VALUE 5620 IF(KWVA1-6) 5630,5630,5640 C DESTINATION IS BC,DE,HL,SP 5630 IBIN1 = 1+8*KWVA1 GO TO 8250 C DESTINATION IS IX,IY 5640 LEN = 4 IBIN1 = KWVA1 IBIN2 = 33 GO TO 8260 C SOURCE IS EXTENDED ADDRESS 5700 IF(KWVA1-4) 5720,5730,5710 5710 IF(KWVA1-6) 5720,5720,5740 C DESTINATION IS BC,DE,SP 5720 IBIN1 = 237 IBIN2 = 75+KWVA1*8 GO TO 8310 C DESTINATION IS HL 5730 IBIN1 = 42 GO TO 8300 C DESTINATION IS IX,IY 5740 IBIN1 = KWVA1 IBIN2 = 42 GO TO 8310 C CHECK FOR SP AS DESTINATION 5800 IF(KWVA1-6) 9100,5810,9100 5810 IF(KWVAL-4) 9100,5820,5830 C SOURCE IS HL 5820 IBIN1 = 249 GO TO 8400 C SOURCE IS IX,IY 5830 IBIN2 = 249 IF(KWVAL-200) 9100,8050,8050 C C PROCESS EX C 6000 KWIND = 100*(KWIN1+KWTY1)+KWIND+KWTYP LEN = 2 DO 6010 I=1,5 IF(KWIND-IEXV(I)) 6010,6020,6010 6010 CONTINUE GO TO 9150 6020 IBIN1 = IEXVI(I) IBIN2 = 227 IF(KWVAL-200) 8400,8050,8050 C C PROCESS BIT,SET,RES C 6100 IF(KWTY1-4) 9100,6110,9100 6110 IF(KWTYP-2) 6120,6130,9100 C SOURCE IS A-L,(HL) 6120 LEN = 2 IBIN1 = 203 NN = 2 GO TO 6140 C SOURCE IS INDEXED 6130 LEN = 4 NN = 4 IBIN1 = KWVAL IBIN2 = 203 KWVAL = 6 6140 IBIN(NN) = IOPVA+KWVAL IF(IVAL1) 9350,6150,6150 6150 IF(IVAL1-7.) 6160,6160,9350 6160 KWVAL = IVAL1 IBIN(NN) = IBIN(NN)+8*KWVAL IF(LEN-4) 9000,8105,8105 C C PROCESS ADD,ADC,SBC C C CHECK IF A IS FIRST OPERAND 6200 IF(KWIN1-2) 6210,4400,6210 6210 IF(KWTY1-6) 9100,6220,9100 6220 IF(KWTYP-6) 9100,6230,9100 6230 IF(KWVA1-4) 9100,6240,6280 C HL IS DESTINATION 6240 IF(KWVAL-200) 6250,9100,9100 C CHECK FOR ADD INSTRUCTION 6250 IF(IOPVA-128) 9100,6260,6270 6260 IBIN1 = 9+KWVAL*8 GO TO 8400 6270 IBIN2 = 142+KWVAL*8-(IOPVA/2) GO TO 8160 6280 IF(KWVA1-200) 9100,9100,6290 C DESTINATION IS IX,IY 6290 IF(KWVAL-4) 6300,9100,6300 6300 IBIN2 = 9+KWVAL*8 KWVAL = KWVA1 IF(IBIN2-256) 8050,6310,6310 6310 IBIN2 = 41 IF(KWIN1-KWIND) 9100,8050,9100 C C PROCESS OUT C 6400 IVAL = IVAL1 I = KWTYP KWTYP = KWTY1 KWTY1 = I KWIN1 = KWIND KWVA1 = KWVAL IBIN1 = 211 GO TO 6510 C C PROCESS IN C 6500 IBIN1 = 219 6510 LEN = 2 IF(KWTY1-1) 9100,6520,9100 6520 IF(KWIN1-2) 6540,6530,6540 C CHECK FOR IMMEDIATE ADDRESSING 6530 IF(KWTYP-5) 9100,8200,6540 C HAVE REGISTER INDIRECT ADDRESSING 6540 IF(KWTYP-8) 9100,6550,9100 6550 IBIN2 = IOPVA+KWVA1*8 GO TO 8160 C C PROCESS RET C 6600 IF(KWTYP-7) 9100,6610,6610 6610 IBIN1 = IOPVA+KWVAL GO TO 8400 C TEST FOR UNCONDITIONAL RETURN 6650 IBIN1 = 201 IF(ICOL-MCOL) 6660,8400,8400 6660 IF(IN(ICOL)-ISEMI) 4020,8400,4020 C C PROCESS JR C 6700 IF(KWTYP-4) 9100,6710,9100 6710 IBIN1 = 24 IF(KWCNT) 8000,8000,6720 C CONDITIONAL JUMP 6720 IF(KWTY1-7) 9100,6740,9100 6740 IBIN1 = 32+KWVA1 GO TO 8000 C C PROCESS CALL C 6800 IBIN1 = 205 IF(KWCNT) 6960,6960,6940 C C PROCESS JP C 6900 IBIN1 = 195 IF(KWCNT) 6910,6910,6940 C HAVE UNCONDITIONAL OR REGISTER INDEXED JUMP 6910 IF(KWTYP-2) 6920,6930,6960 6920 IBIN1 = 233 GO TO 8400 6930 IBIN2 = 233 GO TO 8050 C CONDITIONAL JUMP OR CALL 6940 IF(KWTY1-7) 9100,6950,6950 6950 IBIN1 = IOPVA+KWVA1 6960 IF(KWTYP-4) 9100,8300,9100 C C FORM AND/OR CHECK ADDRESSING MODE VALUES C C RELATIVE ADDRESS BYTE 8000 LEN = 2 NN = 2 IVAL = IVAL-2. IF(IVAL) 8010,8110,8110 8010 IVAL = IVAL+65536. GO TO 8110 C 2 BYTE INSTRUCTION USING IX OR IY 8050 IBIN1 = KWVAL LEN = 2 GO TO 9000 C INDEXED ADDRESSING - CHECK DISPLACEMENT 8100 LEN = 3 IBIN1 = KWVAL 8105 NN = 3 8110 IF(IVAL-128.) 8140,8120,8120 8120 IF(IVAL-65408.) 9350,8130,8130 8130 IVAL = IVAL-65280. 8140 IBIN(NN) = IVAL GO TO 9000 C 2 BYTE INSTRUCTION WITH ED(16) AS FIRST BYTE 8150 IBIN2 = IOPVA 8160 IBIN1 = 237 LEN = 2 GO TO 9000 C 2 BYTE IMMEDIATE INSTRUCTION 8200 LEN = 2 IF(IVAL-256.) 8230,8210,8210 8210 IF(IVAL-65280.) 9350,8220,8220 8220 IVAL = IVAL-65280. 8230 IBIN2 = IVAL GO TO 9000 C 3 OR 4 BYTE IMMEDIATE INSTRUCTION 8250 LEN = 3 8260 GO TO 8320 C 3 OR 4 BYTE EXTENDED ADDRESSING INSTRUCTION 8300 LEN = 3 GO TO 8320 8310 LEN = 4 8320 IBIN(LEN) = IVAL/256. IVAL1 = IBIN(LEN) NN = LEN-1 IBIN(NN) = IVAL-IVAL1*256. GO TO 9000 C 1 BYTE INSTRUCTIONS 8400 LEN = 1 9000 NN=IERR GO TO 9400 C QUESTIONABLE OPERANDS 9100 LEN = 4 9150 NN = 7 GO TO 9400 C VALUE ERROR 9350 NN = 8 9400 IF(IERR1-3) 9420,9410,9420 9410 IERR = 3 9420 IF(IERR-3) 9430,9440,9430 9430 IERR = NN 9440 RETURN END SUBROUTINE FORMT C C THIS ROUTINE IS USED TO FORMAT THE OUTPUT LISTING C INTO THE SPECIFIED COLUMNS C DIMENSION NBUF(80) REAL LC,LODLC,IPVAL,ITABV(200) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) EQUIVALENCE (MCALL(1,1),NBUF(1)) C C *ENTRY PARAMETERS C IN - CONTAINS LINE TO FORMAT C C *EXIT PARAMETERS C IN - FORMATTED LINE C C SET LABEL,OPCODE,ARGUMENT,COMMENT COLUMNS KLABC = 1 KOPCC = 9 KARGC = 14 KCOMC = 27 DO 100 I=1,80 NBUF(I) = IBLNK 100 CONTINUE NPNT = KLABC ICOL = IFCOL LABCT = 1 IF(IN(ICOL)-IAST) 110,900,110 C GET LABEL FIELD 110 NSPAR = 1 CALL FIELD(ICOL) NSPAR = 0 IF(IERR-3) 130,120,900 120 ICOL = ICOL+1 GO TO 140 130 IF(LABCT-IFCOL) 140,140,210 140 ICOL1 = ICOL-1 DO 150 I=LABCT,ICOL1 NBUF(NPNT) = IN(I) NPNT = NPNT+1 150 CONTINUE NPNT = NPNT+1 LABCT = ICOL+1 C GET OPCODE FIELD 200 CALL FIELD(ICOL) 210 GO TO(230,230,230,530,500,530),IERR 230 IF(NPNT-KOPCC) 240,250,250 240 NPNT = KOPCC 250 ICOL1 = ICOL-1 DO 260 I=LABCT,ICOL1 NBUF(NPNT) = IN(I) NPNT = NPNT+1 260 CONTINUE NPNT = NPNT+1 LABCT = ICOL+1 C GET ARGUMENT FIELD 300 IF(NPNT-KARGC) 310,320,320 310 NPNT = KARGC C CHECK IF ARGUMENT EXISTS FOR INSTRUCTION 320 IF(ITYPE) 330,400,350 330 IF(IOPVA-15) 340,500,340 340 IF(IOPVA-17) 400,500,400 350 IF(ITYPE-3) 400,500,360 360 IF(ITYPE-4) 400,500,400 400 CALL FIELD(ICOL) IF(IERR-5) 420,500,600 420 ICOL1 = ICOL-1 DO 430 I=LABCT,ICOL1 NBUF(NPNT) = IN(I) NPNT = NPNT+1 430 CONTINUE NPNT = NPNT+1 C GET COMMENT FIELD 500 IF(NPNT-KCOMC) 510,520,520 510 NPNT = KCOMC 520 CALL FIELD(ICOL) IF(IERR-5) 530,530,600 530 DO 550 I=LABCT,80 IF(NPNT-80) 540,540,600 540 NBUF(NPNT) = IN(I) NPNT = NPNT+1 550 CONTINUE C PLACE FORMATTED LINE INTO IN 600 DO 610 I=1,80 IN(I) = NBUF(I) 610 CONTINUE 900 RETURN END SUBROUTINE FIELD(ICOL) C C THIS ROUTINE OBTAINS THE STARTING AND ENDING COLUMNS C OF THE NEXT SOURCE FIELD C REAL LC,LODLC,IPVAL,ITABV(200) COMMON ICRD,IPRT,IPCH,IMFLE,MCFLE,IMREC,MCREC,IOLIN,IPAGE,LINE COMMON IERRS,IFCOL,MCOL,MLAB,MOPC,IBIT,ICCNT,IWORD,MXMAC,MXPAR COMMON ITAB(3,200),ITABV,INDEX,LTAB,NAME(3),ISSYM,LABCT COMMON KWTYP,KWVAL,KWIND,NJMP,LPAR,NSPAR COMMON MLCOL,MDISK(50),MPARC(50),MPARP(2,60),MCNAM(3,50) COMMON MCALL(85,3),MCNT,MSAVE(3,3),MCSET,MPCNT,NBIN(80) COMMON ICNT,IRLEN,ICKSM,LODLC,IOBIN(72),ISN,LISN,MSREC COMMON IEND,LLEN,IBIN(4),IADDR(4,4),LSOR,LSYM,LMAC,LIF,LOBJ,LREF COMMON LEVEL,LC,IPVAL,LEN,MAC,IOPVA,IARG,IERRI(4),ITYPE,IN(80) COMMON IERR,IAST,IDOLR,IQUOT,ICOLN,ISHRP,IBLNK,ICOMM,ISEMI COMMON ICTAB,IPER,IPLUS,IMIN,IMULT,IDIV,IRPAR,ILPAR,IRSLA,IEQUL COMMON IGRAT,ILESS,IAMP,IVBAR,IALPH(62),LTITL(50) COMMON ICHRA,ICHRB,ICHRC,ICHRD,ICHRE,ICHRF,ICHRH,ICHRK,ICHRL COMMON ICHRM,ICHRN,ICHRO,ICHRQ,ICHRS,ICHRT,ICHRU,ICHRV,ICHRY COMMON MXREF,IXTAB(1024),IXT,IXPNT,IXCNT,IXPAG,IPASS,MCORE(128) C C *ENTRY PARAMETERS C ICOL - STARTING COLUMN OF SCAN C NSPAR - 1 = COLON CAN BE USED AS TERMINATOR C C *EXIT PARAMETERS C ICOL - ENDING COLUMN OF SCAN C LABCT - COLUMN WHERE FIELD STARTS C IERR - RETURN STATUS C 1 = SCAN ENDS ON BLANK OR TAB C 2 = SCAN ENDS WITH SEMICOLON C 3 = SCAN ENDS WITH A COLON C 4 = FIELD TERMINATES PAST LAST COLUMN C 5 = FIRST NON BLANK WAS A SEMICOLON C 6 = NO FIELD FOUND C C SCAN TO START OF FIELD 100 IF(ICOL-MCOL) 110,110,960 110 NCHAR = IN(ICOL) IF(NCHAR-IBLNK) 120,140,120 120 IF(NCHAR-ICTAB) 130,140,130 130 LABCT = ICOL IF(NCHAR-ISEMI) 200,950,200 140 ICOL = ICOL+1 GO TO 100 C GET END OF FIELD 200 IF(ICOL-MCOL) 210,210,940 210 NCHAR = IN(ICOL) IF(NCHAR-IBLNK) 220,910,220 220 IF(NCHAR-ICTAB) 230,910,230 230 IF(NCHAR-ISEMI) 240,920,240 240 IF(NSPAR) 260,260,250 250 IF(NCHAR-ICOLN) 260,930,260 260 IF(NCHAR-IQUOT) 300,270,300 C GET END OF STRING 270 ICOL = ICOL+1 IF(IN(ICOL)-IQUOT) 270,280,270 280 ICOL = ICOL+1 IF(IN(ICOL)-IQUOT) 200,270,200 300 ICOL = ICOL+1 GO TO 200 C 910 IERR = 1 GO TO 990 920 IERR = 2 GO TO 990 930 IERR = 3 GO TO 990 940 IERR = 4 GO TO 990 950 IERR = 5 GO TO 990 960 IERR = 6 990 RETURN END