MPU
  31
A@@@@@SRC
B@@@@@SRC
C@@@@@SRC
D@@@@@SRC
DECK@@SRC
E@@@@@SRC
F@@@@@SRC
G@@@@@SRC
H@@@@@SRC
I@@@@@SRC
J@@@@@SRC
K@@@@@SRC
L@@@@@SRC
M68...002
M6809@015
M@@@@@SRC
MPU@@@JOB
MPURSXPRM
N@@@@@SRC
O@@@@@SRC
P@@@@@SRC
Q@@@@@SRC
R@@@@@SRC
S@@@@@SRC
T@@@@@SRC
U@@@@@SRC
V@@@@@SRC
W@@@@@SRC
X@@@@@SRC
Y@@@@@SRC
Z@@@@@SRC
[\].
A@@@@@SRC
C     .TITLE M6800
C
C  31 JAN 78 (PDH) CONVERT TO A SUBROUTINE TO BE CALLED BY A
C                  TDV FUNCTION INTERFACE SO IT CAN RUN AS SUCH
C                  UNDER MULTIACCESS.
C  12 DEC 77 (PDH) CHANGE 'LULT' TO 6; CHANGE 'IPGLOL' TO 121,
C                  WHICH EFFECTIVELY WIDENS THE PRINT BUFFER.
C  12 OCT 76 (PDH) CHANGE 'LUSI' TO 12 IN AN ATTEMPT TO PREVENT
C                  RSX BATCH FROM HANGING.
C  13 AUG 76 (PDH) CHANGE 'LUOT' BACK TO 7
C  27 JUL 76 (PDH) CHANGE 'LUIO2' TO LUN 9.
C  26 JUL 76 (PDH) CONVERT FOR USE WITH RSX
C   3 JUN 76 (PDH) CHANGE SECONDARY INPUT EXTENSION TO 'PS2'
C   1 JUN 76 (PDH) CHANGE TO 55 LINES PER PAGE ON LISTING
C  24 FEB 76 (PDH) PASS 1 INPUT FROM CARDS, PASS 2 UNPACKED INPUT FROM DISK
C  13 FEB 76 (PDH) REMOVE UNNECESSARY SECTIONS AND ROUTINES CONVERTED
C		TO ASSEMBLER: 'MPUBSM', 'MPUCA1', 'MPUCA2', 'MPUCVC',
C		'MPUNEG', 'MPUOVF', 'MPUXBS', 'MPUXBY', 'MPVDIV', 'MPVMUL'
C  12 FEB 76 (PDH) ARRANGE SUBROUTINES IN ALPHABETICAL ORDER
C  11 FEB 76 - MODIFIED BY PAUL HENDERSON TO RUN WITH PDP-9 WATRAN
C
C     PROGRAM MPAM
C+    NAM: MPAM    VER: 1.0  DAT: 10-01-74  CMP: SIGMA-9
C     PGM: MAIN ROUTINE FOR SYSTEM M68SAM
C
C     SYS: M68SAM
C
C     FNC: THIS ROUTINE CONTAINS ALL COMMON VARIABLES WHICH ARE
C
C     ************************************************
C     ***                                          ***
C     ***       COPYRIGHT 1975 BY MOTOROLA INC     ***
C     ***                                          ***
C     ************************************************
C*
      SUBROUTINE M6800 (PGNM)
      REAL PGNM,PROGNM
      INTEGER KCOMON(1375),IMAGE(40)
      COMMON /PG/ LUIO2,LUTT,PROGNM,EXTSRC,EXTLST,EXTOBJ,EXTPS2
      COMMON ICOMON,LULT,LUSI,LUOT,LLSPSP,ICSHF,IA2SHF,IA1SHF
      COMMON IBPWD,KCFOTB(16),KCFF,KC7F7F,KCFFFF,KC80,KEATB(64)
      COMMON KAETB(64),ISIBUF(80),NB(121),INX,LABEL(4),LABESW
      COMMON IOPCOD(3),NPNAM(3),NPGNO,IPGLOL,IPGLEN,NPLCT
      COMMON IOTBUF(80),IOTINX,IOTSW,IOTCKS,NOTADR,NAM(4)
      COMMON ISIMBF(43),IC,NC,ICSW,IPASS,IOPCLS,IOPIXB,IOPBIN
      COMMON IOPAN1,IPCT,ITERR,NRTSW,NSSCOL,NSOSCH,NAMSW,LSCM
      COMMON LIMA,LDRA,LSBH,LSBO,LSBB,LSPCT,LSASC,NOPT(2)
      COMMON NOPC(4),NOPCL,IXBASE,LSPSP,L8SP,L10,L16,LSP,LASK
      COMMON LPOS,LCOMA,LMNS,LSLASH,L0,L1,L9,LA,LB,LD,LF,LH,LN
      COMMON LO,LQ,LR,LS,LX,LZ,NOSYM,ISYM(813),LSYM
      COMMON /A/ NOPCD(246),IOPBC2(51),IOPBC3(16)
      COMMON /A/ IOPBC4(116),IOPBC5(22)
      EQUIVALENCE (KCOMON(1),ICOMON),(N1,NAM(1)),(N2,NAM(2))
      EQUIVALENCE (N3,NAM(3)),(N4,NAM(4)),(ISILN,ISIMBF(2))
      EQUIVALENCE (ISIFCH,ISIMBF(3)),(IMAGE(1),ISIMBF(4))
      EQUIVALENCE (NOPBAS,NOPT(1)),(NOPLI,NOPT(2))
      DATA EXT1,EXT2,EXT3,EXT4/'SRC','LST','OBJ','PS2'/
C
      KCOMON(1)=1375
C
      LUTT = 13
      LUSI = 15
      LULT = 16
      LUOT = 17
      LUIO2 = 18
      PROGNM = PGNM
      EXTSRC = EXT1
      EXTLST = EXT2
      EXTOBJ = EXT3
      EXTPS2 = EXT4
C
      LLSPSP=65536
      ICSHF=256
      IA2SHF=128
      IA1SHF=2048
      IBPWD=18
      KCFOTB(1)=1
      KCFOTB(2)=2
      KCFOTB(3)=4
      KCFOTB(4)=8
      KCFOTB(5)=16
      KCFOTB(6)=32
      KCFOTB(7)=64
      KCFOTB(8)=128
      KCFOTB(9)=256
      KCFOTB(10)=512
      KCFOTB(11)=1024
      KCFOTB(12)=2048
      KCFOTB(13)=4096
      KCFOTB(14)=8192
      KCFOTB(15)=16384
      KCFOTB(16)=32768
      KCFF=255
      KC7F7F=32639
      KCFFFF=65535
      KC80=128
      LABESW=1
      NPGNO=0
      IPGLOL = 121
      IPGLEN=55
      NPLCT=200
      ISIMBF(1)=0
      ISILN=0
      IPCT=0
      ITERR=0
      NRTSW=1
      NAMSW=1
      LSCM=42
      LIMA=35
      LDRA=0
      LSBH=36
      LSBO=64
      LSBB=37
      LSPCT=42
      LSASC=39
      NOPBAS=16
      NOPLI=2
      NOPC(1)=17474
      NOPC(2)=16723
      NOPC(3)=19529
      NOPC(4)=21332
      NOPCL=4
      IXBASE=3
      LSPSP=8224
      L8SP=14368
      L10=12592
      L16=12598
      LSP=32
      LASK=42
      LPOS=43
      LCOMA=44
      LMNS=45
      LSLASH=47
      L0=48
      L1=49
      L9=57
      LA=65
      LB=66
      LD=68
      LF=70
      LH=72
      LN=78
      LO=79
      LQ=81
      LR=82
      LS=83
      LX=88
      LZ=90
      NOSYM=3
      ISYM(1)=16672
      ISYM(2)=8224
      ISYM(3)=8224
      ISYM(4)=32767
      ISYM(5)=16928
      ISYM(6)=8224
      ISYM(7)=8224
      ISYM(8)=32767
      ISYM(9)=22560
      ISYM(10)=8224
      ISYM(11)=8224
      ISYM(12)=32767
      ISYM(13)=0
      LSYM=813
      CALL MPAM0
      RETURN
      END
[\].
B@@@@@SRC
C.MPAERR (B)
      SUBROUTINE MPAERR (JER)
C+    NAM: MPAERR  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: CROSS-ASSEMBLER ERROR ROUTINE
C
C     SYS: M68SAM
C
C     ENT: JER - ERROR NUMBER TO PRINT
C
C     RTN: JER - N/C
C
C     FNC: PRINT THE ERROR MESSAGE IF THE OPTIONS ARE SET.
C          SHORT ERRORS PRINT ONLY THE ERROR CODE LONG
C          ERROR PRINT THE LAST 6 CHAR WHERE THE SCAN HAS
C          STOP AT.
C*
      INTEGER JB(3),IEB(6)
      REAL EB(3)
      COMMON ICOMON,LULT,LUSI(3),ICSHF,IA2SHF(499),IC,NC(8)
      COMMON ITERR,NRTSW(20),LSPSP,L8SP(3),LSP
      EQUIVALENCE (EB(1),IEB(1))
C***  PRINT THE ERROR MESSAGE
      DO 100 I=1,3
      JB(I)=LSPSP
100   CONTINUE
C***  PRINT LONG ERROR MESSAGES
      JSIC=IC
      IC=JSIC-6
      IF(IC.LT.0) IC=0
      I=1
200   CALL MPUGNC (J)
      JB(I)=J*ICSHF+LSP
      IF(IC.EQ.JSIC) GO TO 300
      CALL MPUGNC (J)
      JB(I)=JB(I)-LSP+J
      I=I+1
      IF(IC.LT.JSIC) GO TO 200
C***  PRINT THE ERROR MESSAGE
300   CALL MPUCA2 (JB,3)
      DO 302 I=1,3
      K = I*2 - 1
      IEB(K) = JB(I)
302   CONTINUE
      WRITE (LULT,301) JER,EB
301   FORMAT(10H ****ERROR,I4,2X,3A2)
      CALL MPAPAG (1)
      ITERR=ITERR+1
      RETURN
      END
[\].
C@@@@@SRC
C.MPAFOP (C)
      SUBROUTINE MPAFOP
C+    NAM: MPAFOP  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: SEARCH THE OPCODE TABLES
C
C     SYS: M68SAM
C
C     ENT: N/A
C     RTN: N/A
C
C     FNC: SEARCH THE OPCODE TABLES. IF THE OPCODE IS FOUND,
C          ITS INDEX IS RETURNED IN 'IOPIXB'. IF NOT FOUND,
C          'IOPIXB' AND 'IOPCLS' (CLASS) ARE SET TO 1.
C*
      COMMON ICOMON(364),IOPCOD(3),NPNAM(142),IOPCLS,IOPIXB
      COMMON IOPBIN
      COMMON /A/ NOPCD(246),IOPBC2(51),IOPBC3(16)
      COMMON /A/ IOPBC4(116),IOPBC5(22)
      DATA LASK0/10800/,LASK9/10809/
      IOPCLS=0
      IOPIXB=1
      I=1
240   N=NOPCD(I)
      I=I+1
      IF(IOPCOD(1).EQ.N) GO TO 245
      IF(N.LT.LASK0.OR.N.GT.LASK9) GO TO 250
C***  NEW OPCODE CLASS FOUND
      IOPCLS=IOPCLS+1
      IOPIXB=1
      IF(N.NE.LASK9) GO TO 240
C***  UNDEFINED OPCODE (SET INDEX TO UNDEFINED OPCODE)
      IOPCLS=1
      GO TO 255
245   N=NOPCD(I)
      IF(IOPCOD(2).EQ.N) GO TO 255
250   I=I+1
      IOPIXB=IOPIXB+1
      GO TO 240
C***  OPCODE FOUND (PLACE THE OPCODE BINARY IN IOPBIN)
255   IOPBIN=0
      RETURN
      END
[\].
D@@@@@SRC
C.MPAFSY (D)
      SUBROUTINE MPAFSY (JNM,JRS,JSI)
C+    NAM: MPAFSY  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: FIND SYMBOL IN THE SYMBOL TABLE
C
C     SYS: M68SAM
C
C
C     ENT: JNM - 6 CHAR SYMBOL TO FIND IN SYSTEM'S R2 FORMAT
C          JRS - N/A
C          JSI - N/A
C
C     RTN: JNM - WORDS 1 TO 3 N/C
C              - 4TH WORD EQUALS THE SYMBOLS VALUE IF FOUND
C          JRS - 1 => SYMBOL FOUND
C              - 2 => SYMBOL FOUND, BUT ERROR FLAG SET
C              - 3 => SYMBOL NOT IN THE TABLE
C          JSI - SYMBOL TABLE INDEX TO WORD 1 (IF FOUND)
C
C     FNC: SEARCH THE SYMBOL TABLE FOR 6 CHARACTER SYMBOL
C          SYSTEM'S R2 ASCII FORMAT (WORDS 1-3 OF JNM)
C          AND RETURN IT'S VALUE IN WORD 4 IF FOUND.
C*
      INTEGER JNM(4)
      COMMON ICOMON(26),KC7F7F,KCFFFF,KC80,KEATB(532),ISYM(813)
      COMMON LSYM
      DO 100 I=1,LSYM,4
      J=ISYM(I)
      IF(J.EQ.0) GO TO 110
      IF(JNM(1).NE.IAND(J,KC7F7F)) GO TO 100
      IF(JNM(2).NE.ISYM(I+1)) GO TO 100
      IF(JNM(3).EQ.ISYM(I+2)) GO TO 120
100   CONTINUE
      I=LSYM
C***  SYMBOL NOT FOUND
110   JRS=3
      GO TO 130
C***  SYMBOL WAS FOUND
120   JRS=1
      IF(IAND(J,KC80).NE.0) JRS=2
      JNM(4)=ISYM(I+3)
130    JSI=I
      RETURN
      END
[\].
DECK@@SRC
 NAM DECK
*+    NAM: M68PGM  VER: 1.0  DAT: 11-15-74  CMP: M6800 
 ORG 256
COUNT EQU @3
START LDS #STACK INZ STACK POINTER
 LDX ADDR
 LDA B  #COUNT IMMEDIATE ADDRESSING
BACK LDA A 10 DIRECT ADDRESSING    
 CMP A 2,X INDEXED ADDRESSING
 BEQ FOUND RELATIVE ADDRESSING
 DEX IMPLIED ADDRESSING
 DEC B  ACCUMULATOR ONLY ADDRESSING
 BNE BACK 
 WAI  WAIT FOR INTERRUPT 
 SPC 1
FOUND JSR SUBRTN JUMP TO SUBROUTINE
 JMP START EXTENDED ADDRESSING
* COMMENT STATEMENT NOT TRUNCATION 01234567890123456789
SUBRTN TAB COMMENT FIELD TRUNCATION0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678
 ORA A BYTE    SET MOST SIGNIFICANT BIT 
 RTS  RETURN FROM SUBROUTINE  
 SPC 2
 RMB 20 SCRATCH AREA FOR STACK
STACK RMB 1 START OF STACK    
BYTE FCB $80 FORM CONSTANT BYTE    
ADDR FDB DATA FORM CONSTANT DOUBLE BYTE 
DATA FCC 'SET' FORM CONSTANT DATA STRING (ASCII)  
 END 
[\].
E@@@@@SRC
C.MPAGAM (E)
      SUBROUTINE MPAGAM (JM,JSW)
C+    NAM: MPAGAM  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: GET ADDRESS MODE
C
C     SYS: M68SAM
C
C     ENT: JM  - N/A
C          JSW - N/A
C
C     RTN: JM  - 1=> DIRECT ADDRESS MODE
C              - 2=> INDEXED ADDRESS MODE
C              - 3=> IMMEDIATE ADDRESS MODE
C              - 4=> EXTENDED ADDRESS MODE
C          JSW - SEE 'MPAOPR' FOR 'JSW' SETTINGS
C
C     FNC: GET THE INSTRUCTIONS ADDRESS MODE
C*
      COMMON ICOMON(505),IC,NC,ICSW,IPASS(4),IOPAN1,IPCT(7)
      COMMON LIMA,LDRA,LSBH(17),LSP,LASK(18),LX
      IOPAN1=0
      JSW=1
      JC=NC
      CALL MPUGNC(NC)
      JM=3
      IF(LIMA.EQ.JC) GO TO 10
      JM=1
      IF(LDRA.EQ.JC) GO TO 10
      IF(JC.EQ.LX.AND.NC.EQ.LSP) GO TO 40
      JM=0
      IC=IC-2
      CALL MPUGNC(NC)
10    CALL MPAOPR (IOPAN1,JSW)
      GO TO (50,30,20,20,20,50),ICSW
C***  ERROR IN OPERAND
20    JM=4
      JSW=5
      GO TO 60
C***  OPERAND ENDS WITH A COMMA ','
30    CALL MPUGNC(JC)
      CALL MPUGNC(NC)
      IF(JC.NE.LX.OR.NC.NE.LSP) GO TO 20
C***  INDEXED ADDRESS MODE
40    JM=2
50    IF(JM.NE.0) GO TO 60
C***  MODE IS BY WORD LENGTH
      JM=1
      IF(JSW.NE.1) JM=4
60    RETURN
      END
[\].
F@@@@@SRC
C.MPAM0 (F)
C
C  21 MAR 78 (PDH) ATTACH LISTING AND 'PAPER TAPE' DEVICES; IGNORE
C                  IEV = -6 VALUES.
C  10 MAR 78 (PDH) CLOSE SOURCE INPUT FILE AFTER ASSEMBLY; 'CALL RSREAD'
C   9 MAR 78 (PDH) 'FILE NOT FOUND' IS -11 DECIMAL
C  31 JAN 78 (PDH) MAKE SOME CHANGES FOR USE UNDER MULTIACCESS
C                  AS A TDV FUNCTION.
C  12 DEC 77 (PDH) DELETE DOES WORK IF YOU KNOW HOW!  PUT IT BACK.
C  15 OCT 76 (PDH) REMOVE LINE PRINTER FLUSH - NOT NEEDED IN BATCH
C   9 SEP 76 (PDH) DELETE DOESN'T WORK!  SIMULATE IT (NEARLY) BY
C                  WRITING OUT A VERY SHORT FILE OF THE SAME NAME.
C  27 JUL 76 (PDH) DELETE SECONDARY FILE AFTER USE; CHANGE TO RSX
C                  FILE NAME SPECIFICATION; FLUSH PRINTER WHEN DONE.
C  26 JUL 76 (PDH) CONVERT TO RSX
C   2 MAR 76 (PDH) SEPARATE PASS 1 ERRORS FROM PASS 2 LISTING
C  24 FEB 76 (PDH) OPEN FILE TO STORE UNPACKED INPUT FOR PASS 2
C  17 FEB 76 (PDH) SPECIFY INPUT FILE NAME AND OPEN THE FILE
C
      SUBROUTINE MPAM0
C+    NAM: MPAM0   VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: MAIN ROUTINE FOR THE CROSS-ASSEMBLER
C
C     SYS: M68SAM
C
C     ENT: N/A
C     RTN: N/A
C
C     FNC: MAIN CONTROL ROUTINE FOR THE CROSS-ASSEMBLER.
C*
      COMMON /PG/ LUIO2,LUTT,PROGNM,EXTSRC,EXTLST,EXTOBJ,EXTPS2
      COMMON ICOMON,LULT,LUSI,LUOT,LLSPSP,ICSHF(362),NPNAM(3)
      COMMON NPGNO(138),IPASS,IOPCLS(5),ITERR,NRTSW(12),NOPT(2)
      COMMON NOPC(5),IXBASE
      EQUIVALENCE (NOPBAS,NOPT(1)),(NOPLI,NOPT(2))
C***  INITIALIZE THE ASSEMBLER
C
      CALL SEEK (LUSI,PROGNM,EXTSRC,IEV)
      CALL WAITFR (IEV)
      IF (IEV .GT. 0) GO TO 5
      IF (IEV .EQ. (-11)) GO TO 4
      IF (IEV .EQ. ( -6)) GO TO 5
      WRITE (LUTT,598) IEV
      RETURN
   4  WRITE (LUTT,599) PROGNM
      RETURN
 599  FORMAT (' FILE ',A5,' SRC NOT FOUND')
 598  FORMAT (' SEEK ERROR',I7,' (DECIMAL)')
C
C  IN ORDER TO PREVENT POSSIBLE CONFUSING OCCURRENCES, IT IS
C  CONSIDERED PRUDENT TO ATTACH THE LISTING AND OBJECT DEVICES.
C
   5  CALL ATTACH (LULT,IEV)
      CALL WAITFR (IEV)
      CALL ENTER (LULT,PROGNM,EXTLST)
      CALL ATTACH (LUOT,IEV)
      CALL WAITFR (IEV)
      CALL ENTER (LUOT,PROGNM,EXTOBJ)
      CALL ENTER(LUIO2,PROGNM,EXTPS2)
C
C  RESET THE 'READ' SUBROUTINE IN CASE THIS IS NOT THE 1ST TIME.
C
      CALL RSREAD
C
C***  SPACE THE PAGE HEADER'S PROGRAM NAME
      DO 10  I=1,3
      NPNAM(I)=LLSPSP
10    CONTINUE
C
C  NO LINE COUNT FOR PASS 1
C
      NOPLI = 1
C***  CALL PASS 1 BUILD SYMBOL TABLE
      IPASS=1
      CALL MPAM1
C***  INITIALIZE PASS 2.  ISSUE TOP OF FORM TO CLEAR PRINTER PAPER.
      NOPLI=2
      CALL MPAPAG (-1)
      IXBASE=3
      NOPBAS=16
C***  CALL PASS 2 OUTPUT LISTING AND TAPE FILE
      IPASS=2
      CALL MPAM2
C***  CALL PASS 3 LISTING SYMBOL TABLE AND CLOSE FILES
      CALL MPAM3
      CALL CLOSE (LUSI)
C
C  HAVE TO USE NAME & EXT TO BE ABLE TO MAKE USE OF 'IEV'
C
      CALL CLOSE (LULT,PROGNM,EXTLST,IEV)
      CALL WAITFR (IEV)
      CALL CLOSE (LUIO2)
      CALL DELETE (LUIO2,PROGNM,EXTPS2,IEV)
      CALL WAITFR (IEV)
      RETURN
      END
[\].
G@@@@@SRC
C.MPAM1 (G)
C
C  31 JAN 78 (PDH) CHANGE COMMON 'PG' FOR MULTIACCESS
C  24 FEB 76 (PDH) NO MORE '/*'; USE SUBROUTINE 'READ'; STORE
C                  UNPACKED INPUT ON DISK FOR PASS 2
C  17 FEB 76 (PDH) CHANGE 'END= ' TO CHECK FOR '/*'
C
      SUBROUTINE MPAM1
C+    NAM: MPAM1   VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: PASS ONE OF THE MPU CROSS ASSEMBLER
C
C     SYS: M68SAM
C
C     ENT: N/A
C     RTN: N/A
C
C     FNC: BUILD THE SYMBOL TABLE
C*
      COMMON /PG/LUIO2
      COMMON ICOMON(2),LUSI,LUOT,LLSPSP,ICSHF(152),ISIBUF(80)
      COMMON NB(122),LABEL(4),LABESW,IOPCOD(3),NPNAM(3)
      COMMON NPGNO(92),ISIMBF(43),IC,NC,ICSW,IPASS,IOPCLS
      COMMON IOPIXB,IOPBIN(2),IPCT,ITERR,NRTSW(3),NAMSW,LSCM
      COMMON LIMA(15),LSPSP,L8SP(3),LSP,LASK(8),LA,LB
      COMMON /A/ NOPCD(246),IOPBC2(51),IOPBC3(16)
      COMMON /A/ IOPBC4(116),IOPBC5(22)
      EQUIVALENCE (ISILN,ISIMBF(2))
      DATA K0/0/,K1/1/
C
      IE=204
      JRDNO=0
      JRLNSW=2
C***  SETUP THE P.T. FILE
      CALL MPUPTS (K1,K0,K0)
      GO TO 140
C***  ERROR '206' SYMBOL HAS BEEN DEFINED, (DOUBLE DEFINDED)
100   IF(LABESW.EQ.2) CALL MPAERR (206)
      LABESW=1
      GO TO (110,120),NAMSW
C***  ERROR '201' NO NAM RECORD OR MULT NAM RECORDS
110   CALL MPAERR (201)
      NAMSW=2
120   IF(ITERR.NE.JTERR) CALL MPAPRL (545)
140   JTERR=ITERR
      DO 150 I=1,80
      ISIBUF(I)=LLSPSP
150   CONTINUE
C
C***  READ IN ONE SOURCE STATEMENT
C
      CALL READ (ISIBUF,LUSI)
153   JRDNO=JRDNO+1
      ISILN=JRDNO
C***  PACK THE SOURCE RECORD INTO THE SOURCE IMAGE BUFFER
      CALL MPUPIB (ISIBUF,JRLNSW)
      WRITE (LUIO2) ISIMBF,IC,NC,JRLNSW,ICSW
      LEVEL=1
      LABEL(1)=0
      LABEL(4)=0
      GO TO 180
C***  GET THE NEXT CHAR
170   CALL MPUGNC (NC)
180   GO TO (190,260,280,310),LEVEL
190   GO TO (250,220,200,240,230,210),ICSW
C***  ERROR '202' LABEL OR OPCODE MUST START WITH A ALPHA CHAR
200   IE=IE-1
C***  ERROR '203' BLANK RECORD OR THE RECORD ONLY CONTAINS A LABEL
210   IE=IE-1
C***  ERROR '204' SYNTAX ERROR
220   CALL MPAERR (IE)
      IE=204
      GO TO 440
230   IF (NC.NE.LSCM) GO TO 220
C***  RECORD IS A COMMENT RECORD (SKIPIT)
      GO TO 100
C***  GET THE STATEMENT'S LABEL
240   CALL MPUBNM (LABEL)
C***  ERROR '205' ILLEGAL STATEMENT LABEL (MUST END WITH A SPACE)
      IF (ICSW.NE.1) CALL MPAERR (205)
C***  STORE THE LABEL IN THE SYMBOL TABLE
      LABEL(4)=IPCT
      CALL MPASSY (LABEL,1,LABESW)
250   LEVEL=2
C***  LEVEL 2 SCAN FOR START OF OPCODE FIELD
260   GO TO (170,200,200,270,200,210),ICSW
C***  GET THE OPCODE
270   CALL MPUBNM (IOPCOD)
      IF(ICSW.NE.1) GO TO 220
      CALL MPAFOP
      IF(IOPCLS.EQ.2) GO TO 460
      LEVEL=3
C     LEVEL 3 SCAN FOR 'A ' OR 'B '
280   GO TO (170,320,320,290,320,320),ICSW
290   IF(NC.NE.LA.AND.NC.NE.LB) GO TO 320
      JC=NC
      CALL MPUGNC(NC)
      IF(ICSW.EQ.1) GO TO 300
      IC=IC-2
      CALL MPUGNC(NC)
      GO TO 320
C***  OPCODE IS 'CCC X ' WHERE) X= A OR B
300   IOPCOD(2)=IOPCOD(2)-LSP+JC
      CALL MPAFOP
      IF(IOPCLS.EQ.2) GO TO 460
C***  SCAN TO THE START OF THE OPERAND FIELD
      LEVEL=4
310   GO TO (170,320,320,320,320,320),ICSW
320   GO TO (330,460,450,420,400),IOPCLS
C
C***  DIRECTIVE OPCODES
C
C***  ASSEMBLER CLASS 1
330   IF(IOPIXB.GT.4) GO TO 390
      GO TO (340,350,360,340),IOPIXB
C***  ERROR '207' UNDEFINED OPCODE
340   CALL MPAERR (207)
      GO TO 440
C***  'NAM' OPCODE
350   IF(NAMSW.EQ.2) GO TO 110
      CALL MPUBNM(NPNAM)
      NAMSW=2
      IF(NPNAM(1).EQ.LSPSP) GO TO 220
      CALL MPUCA2(NPNAM,3)
      GO TO 100
C***  'END' OPCODE
360   RETURN
C***  GO TO THE DIRECTIVE OPCODE PROCCESSOR
390   CALL MPAPSC
      IF(IPCT.EQ.0) GO TO 120
      GO TO 100
C
C***  2 OR 3 BYTE INSTRUCTION (INDEXED AND EXTENDED MODE ONLY)
C
C***  ASSEMBLER CLASS 5
400   CALL MPAGAM (IAMOD,JOPRSW)
      IF(JOPRSW.GT.4) GO TO 220
      GO TO (440,450,410,440),IAMOD
410   CALL MPAERR (209)
      GO TO 440
C
C***  2 OR 3 BYTE INSTRUCTION
C
C***  ASSEMBLER CLASS 4
420   CALL MPAGAM (IAMOD,JOPRSW)
      IF(JOPRSW.GT.4) GO TO 220
      IOPIXB=IOPIXB*4-4+IAMOD
      IF(IOPBC4(IOPIXB).LT.0) GO TO 410
      IF(IOPIXB.LT.13.AND.IAMOD.EQ.3) GO TO 440
      GO TO (430,450,450,440),IAMOD
430   IF(IOPIXB.NE.21.AND.IOPIXB.NE.25) GO TO 450
C***  3 WORD OPCODES
440   IPCT=IPCT+1
C***  2 WORD OPCODES
450   IPCT=IPCT+1
C***  1 WORD OPCODES
460   IPCT=IPCT+1
      GO TO 100
      END
[\].
H@@@@@SRC
C.MPAM2 (H)
C
C  31 JUL 78 (PDH) WAIT FOR 'PUNCH' TO FINISH CLOSING
C  31 JAN 78 (PDH) CHANGE COMMON 'PG' FOR MULTIACCESS
C  24 FEB 76 (PDH) READ UNPACKED INPUT FROM DISK
C  18 FEB 76 (PDH) CLOSE PAPER TAPE PUNCH
C  17 FEB 76 (PDH) REMOVE 'END= ' AND OPEN SPECIFIED FILE FOR PASS 2
C
      SUBROUTINE MPAM2
C+    NAM: MPAM2   VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: PASS TWO OF THE MPU CROSS-ASSEMBLER
C
C     SYS: M68SAM
C
C     ENT: N/A
C     RTN: N/A
C
C     FNC:
C*
      COMMON /PG/ LUIO2,LUTT,PROGNM,EXT(3),EXTPS2
      COMMON ICOMON(2),LUSI,LUOT,LLSPSP,ICSHF(152),ISIBUF(80)
      COMMON NB(122),LABEL(4),LABESW,IOPCOD(3),NPNAM(95)
      COMMON ISIMBF(43),IC,NC,ICSW,IPASS,IOPCLS,IOPIXB,IOPBIN
      COMMON IOPAN1,IPCT,ITERR,NRTSW,NSSCOL,NSOSCH,NAMSW,LSCM
      COMMON LIMA(19),LSP,LASK(8),LA,LB
      COMMON /A/ NOPCD(246),IOPBC2(51),IOPBC3(16)
      COMMON /A/ IOPBC4(116),IOPBC5(22)
      EQUIVALENCE (ISILN,ISIMBF(2))
      DATA K0/0/,K2/2/,K3/3/
C
      IE=204
      IPCT=0
      JRLNSW=2
C***  REWIND THE SOURCE INPUT FILE
      CALL CLOSE (LUIO2)
      CALL SEEK (LUIO2,PROGNM,EXTPS2)
C
C***  READ IN THE NEXT SOURCE RECORD
C
 100  READ (LUIO2) ISIMBF,IC,NC,JRLNSW,ICSW
      LEVEL=1
      NRTSW=1
      NSOSCH=LSP
      IOPAN1=0
      LABEL(1)=0
      GO TO 120
C***  GET THE NEXT CHAR
110   CALL MPUGNC (NC)
120   GO TO (130,220,240,280),LEVEL
130   GO TO (210,160,140,200,180,150),ICSW
C***  ERROR '202' LABEL OR OPCODE MUST START WITH A ALPHA CHAR
140   IE=IE-1
C***  ERROR '203' BLANK RECORD OR THE RECORD ONLY CONTAINS A LABEL
150   IE=IE-1
C***  ERROR '204' SYNTAX ERROR
160   CALL MPAERR (IE)
      IE=204
170   IOPBIN=0
      IOPAN1=0
      NRTSW=1
      CALL MPAPRL(311)
      IPCT=IPCT+3
      GO TO 100
180   IF(NC.NE.LSCM) GO TO 160
C***  RECORD IS A COMMENT RECORD (SKIPIT)
190   CALL MPAPRL(33)
      GO TO 100
C***  GET THE STATEMENT'S LABEL
200   CALL MPUBNM (LABEL)
210   LEVEL=2
      GO TO 110
C***  LEVEL 2 SCAN FOR START OF OPCODE FIELD
220   GO TO (110,140,140,230,140,150),ICSW
C***  GET THE OPCODE
230   CALL MPUBNM (IOPCOD)
      IF(ICSW.NE.1) GO TO 160
      CALL MPAFOP
      IF(IOPCLS.EQ.2) GO TO 300
      LEVEL=3
C***  LEVEL 3 SCAN FOR 'A ' OR 'B '
240   GO TO (110,290,290,250,280,290),ICSW
250   IF(NC.NE.LA.AND.NC.NE.LB) GO TO 290
      JC=NC
      CALL MPUGNC(NC)
      IF(ICSW.EQ.1) GO TO 260
      IC=IC-2
      CALL MPUGNC(NC)
      GO TO 270
C***  OPCODE IS 'CCC X ' WHERE: X= A OR B
260   IOPCOD(2)=IOPCOD(2)-LSP+JC
      CALL MPAFOP
      IF(IOPCLS.EQ.2) GO TO 300
270   LEVEL=4
C***  LEVEL 4 SCAN TO THE START OF THE OPERAND
280   GO TO (110,290,290,290,290,290),ICSW
290   NRTSW=3
300   NSSCOL=IC
      IF(LABEL(1).EQ.0.OR.IOPCLS.EQ.1) GO TO 310
      CALL MPAFSY (LABEL,J,I)
      IF(LABEL(4).EQ.IPCT) GO TO 310
C***  ERROR '220' PHASING ERROR
      CALL MPAERR (220)
      IPCT=LABEL(4)
310   GO TO (320,370,380,390,480),IOPCLS
C
C***  DIRECTIVE OPCODES
C
C***  ASSEMBLER CLASS 1
320   IF(IOPIXB.GT.4) GO TO 360
      GO TO (330,190,340,340),IOPIXB
C***  ERROR '207' UNDEFINED OPCODE
330   CALL MPAERR (207)
      GO TO 170
C***  'END' OPCODE
340   CALL MPAPRL(33)
C***  OUTPUT THE LAST P.T. RECORD
      CALL MPUPTS (K3,K0,K0)
C
C  HAVE TO INCLUDE FILE NAME, EXTENSION, TO BE ABLE TO USE 'IEV'
C
      CALL CLOSE (LUOT,PROGNM,EXT(3),IEV)
      CALL WAITFR (IEV)
      RETURN
C***  GO TO THE DIRECTIVE OPCODE PROCCESSOR
360   CALL MPAPSC
      GO TO 100
C
C***  1 BYTE INSTURCTIONS
C
C***  ASSEMBLER CLASS 2
370   IOPBIN=IOPBC2(IOPIXB)
      NRTSW=2
      CALL MPAPRL(295)
      IPCT=IPCT+1
      GO TO 100
C
C***  2 BYTE RELATIVE INSTRUCTIONS
C
C***  ASSEMBLER CLASS 3
380   IOPBIN=IOPBC3(IOPIXB)
      CALL MPAOPR (IOPAN1,JOPRSW)
C***  ERROR '208' RELATIVE BRANCH OUT OF RANGE
      IF(IOPAN1.LT.(IPCT-125).OR.IOPAN1.GT.(IPCT+129)) CALL MPAERR (208)
      CALL MPUADR (IOPAN1,K2,IPCT,JSW)
      CALL MPUADR (IOPAN1,K2,K2,JSW)
      CALL MPAPRL(303)
      IPCT=IPCT+2
      GO TO 100
C
C***  2 OR 3 BYTE INSTRUCTIONS
C
C***  ASSEMBLER CLASS 4
390   CALL MPAGAM (IAMOD,JOPRSW)
      IF(JOPRSW.GT.4) GO TO 160
      IOPIXB=IOPIXB*4-4+IAMOD
      IOPBIN=IOPBC4(IOPIXB)
      IF(IOPBIN.GE.0) GO TO (410,420,450,460),IAMOD
C***  ERROR '209' ILLEGAL ADDRESS MODE
400   CALL MPAERR (209)
      IOPBIN=0
      GO TO 470
C***  DIRECT ADDRESS MODE
C***  CHANGE MODE FOR 'JMP' AND 'JSR' TO EXTENDED
410   IF(IOPIXB.EQ.21.OR.IOPIXB.EQ.25) GO TO 460
      GO TO 430
C***  INDEXED ADDRESS MODE
420   CONTINUE
430   IF(JOPRSW.EQ.1) GO TO 440
C***  ERROR '210' BYTE OVERFLOW (> 256)
      CALL MPAERR (210)
      IOPAN1=255
440   CALL MPAPRL(303)
      IPCT=IPCT+2
      GO TO 100
C***  IMMEDIATE ADDRESS MODE
450   IF(IOPIXB.LT.13) GO TO 470
      GO TO 430
C***  EXTENDED ADDRESS MODE
460   CONTINUE
470   CONTINUE
      CALL MPAPRL(311)
      IPCT=IPCT+3
      GO TO 100
C
C***  2 OR 3 BYTE INSTRUCTIONS (INDEXED OR EXTENDED MODE ONLY)
C
C***  ASSEMBLER CLASS 5
480   IOPIXB=IOPIXB*2-1
      CALL MPAGAM (IAMOD,JOPRSW)
      IF(JOPRSW.GT.4) GO TO 160
      GO TO (500,490,400,500),IAMOD
490   IOPBIN=IOPBC5(IOPIXB)
      GO TO 430
500   IOPBIN=IOPBC5(IOPIXB+1)
      GO TO 470
      END
[\].
I@@@@@SRC
C.MPAM3 (I)
C
C   7 MAR 78 (PDH) KEEP SYMBOL TABLE UNDER 80 COLUMNS
C
      SUBROUTINE MPAM3
C+    NAM: MPAM3   VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: PASS THREE OF THE MPU CROSS-ASSEMBLER
C
C     SYS: M68SAM
C
C     ENT: N/A
C     RTN: N/A
C
C     FNC: PRINT THE SYMBOL TABLE
C*
      INTEGER JLDF(3)
      COMMON ICOMON,LULT,LUSI(3),ICSHF,IA2SHF(19),KCFF,KC7F7F
      COMMON KCFFFF(210),NB(121),INX,LABEL(12),IPGLOL,IPGLEN
      COMMON NPLCT,IOTBUF(84),NAM(4),ISIMBF(52),ITERR,NRTSW(12)
      COMMON NOPT(2),NOPC(5),IXBASE,LSPSP(4),LSP,LASK(20),NOSYM
      COMMON ISYM(813)
      EQUIVALENCE (NOPBAS,NOPT(1)),(NOPLI,NOPT(2))
      DATA JLDF(1)/6/,JLDF(2)/5/,JLDF(3)/4/
      IF(NOPLI.EQ.1.OR.NOSYM.LT.4) GO TO 150
      JLF=JLDF(IXBASE)
      NL = MIN0 (IPGLOL,72)/(JLF+9)
      IF(NPLCT.LT.10) GO TO 100
      IF(NOSYM/NL+NPLCT+10.GT.IPGLEN) CALL MPAPAG(0)
100   WRITE (LULT,101)
      WRITE (LULT,101)
101   FORMAT (1H )
      WRITE (LULT,105)
105   FORMAT (13H SYMBOL TABLE)
      WRITE (LULT,101)
      WRITE (LULT,101)
      CALL MPAPAG (5)
      N=3
110   L=0
      INX=0
120   N=N+1
      J=N*4-3
      NAM(1)=IAND(KC7F7F,ISYM(J))
      NAM(2)=ISYM(J+1)
      NAM(3)=ISYM(J+2)
      NAM(4)=ISYM(J+3)
      CALL MPUSNC(LSP)
      DO 130 I=1,3
      J=NAM(I)/ICSHF
      CALL MPUSNC(J)
      J=IAND(KCFF,NAM(I))
      CALL MPUSNC(J)
130   CONTINUE
      CALL MPUSNC(LSP)
      CALL MPUCNA (NAM(4),NOPBAS,JLF)
      CALL MPUSNC(LSP)
      L=L+1
      IF(N.GE.NOSYM) GO TO 140
      IF(L.LT.NL) GO TO 120
140   CALL MPAPA1 (2,NB,INX)
      CALL MPAPAG (1)
      IF(N.LT.NOSYM) GO TO 110
150   IF(ITERR.EQ.0) GO TO 165
      WRITE (LULT,101)
      WRITE (LULT,101)
      WRITE (LULT,160) ITERR
160   FORMAT (13H TOTAL ERRORS,I4)
C
C  CLOSE LISTING DEVICE
C
165   CALL CLOSE (LULT)
      RETURN
      END
[\].
J@@@@@SRC
C.MPAOPR (J)
      SUBROUTINE MPAOPR (JV,JSW)
C+    NAM: MPAOPR  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: FORM THE OPERAND'S VALUE
C
C     SYS: M68SAM
C
C     ENT: JV  - N/A
C          JSW - N/A
C
C     RTN: JV  - VAULE OF THE OPERAND
C          JSW - OPERAND VAULE STATUS:
C              - 1=> 8 BIT VAULE
C              - 2=> 16 BIT VAULE
C              - 3=> VALUE OVERFLOWED 16 BITS
C              - 4=> UNDEFINED SYMBOLS IN THE OPERAND FIELD
C              - 5=> SYNTAX ERROR IN THE FILED
C
C     FNC: THE ROUTINE SCANS TO THE START OF THE OPERAND FIELD
C          AND THEN FORMS THE VALUE OF THE OPERAND BY THE
C          OPERATIONAL SIGNS IN THE FIELD.  OPERATIONS ARE
C          PERFORMED IN A LEFT TO RIGHT SCAN.
C*
      COMMON ICOMON(458),NAM(4),ISIMBF(44),NC,ICSW,IPASS
      COMMON IOPCLS(4),IPCT,ITERR(8),LSBH,LSBO,LSBB,LSPCT,LSASC
      COMMON NOPT(13),LASK,LPOS,LCOMA,LMNS,LSLASH
      JV=0
      NS=1
      JSW=1
      LEVS=1
      JBRSW=2
      GO TO 110
100   CALL MPUGNC (NC)
110   GO TO (120,150,160),LEVS
C***  * * *  ' ' ',' 0-9 A-Z SPE
120   GO TO (170,175,280,180,190,170),ICSW
C***  SYNTAX ERROR
130   JSW=5
140   LEVS=2
150   GO TO (170,170,100,100,100,170),ICSW
160   GO TO (170,170,130,130,190,170),ICSW
C***  END OF THE OPERAND
170   IF(JBRSW.EQ.2.AND.JSW.EQ.1) JSW=5
175   RETURN
C***  BUILD SYMBOL AND LOOK IT UP IN THE SYMBOL TABLE
180   CALL MPUBNM (NAM)
      CALL MPAFSY (NAM,I,J)
      N=NAM(4)
      JBRSW=1
C***  ERROR '222' A ERROR IN THE SYMBOL (SYMBOL WAS REDEFINED
C***             OR A SYNTAX ERROR IN A 'EQU')
      IF(IPASS.EQ.2.AND.I.EQ.2) CALL MPAERR (222)
      IF(I.LT.3) GO TO 300
C***  ERROR '211' UNDEFINED SYMBOL
      IF(IPASS.EQ.2) CALL MPAERR (211)
      JSW=4
      GO TO 140
C***  SPECIAL CHARACTER
190   IF(NS.EQ.0) GO TO 200
C***  A SIGN HAS BEEN DEFINED
      IF(NC.NE.LSPCT) GO TO 200
C***  USE CURRENT P COUNTER
      N=IPCT
      GO TO 260
200   IF(NC.EQ.LPOS) GO TO 230
      IF(NS.GT.1) GO TO 250
      IF(NC.EQ.LMNS) GO TO 220
      IF(NC.EQ.LASK) GO TO 210
      IF(NC.NE.LSLASH) GO TO 250
C***  OPERATION SIGN CHARACTER
      NS=4
      GO TO 240
210   NS=3
      GO TO 240
220   NS=2
      GO TO 240
230   NS=1
240   LEVS=1
      GO TO 100
250   IF(NC.NE.LSASC) GO TO 270
C***  ASCII CHARACTER
      CALL MPUGNC(N)
260   CALL MPUGNC(NC)
      GO TO 290
270   IF(NC.NE.LSBH.AND.NC.NE.LSBO.AND.NC.NE.LSBB) GO TO 130
280   CALL MPUFNO(N,I)
      IF(I.EQ.2) GO TO 130
290   JBRSW=1
C***  END OF FIELD
300   IF(NS.EQ.0) GO TO 130
      CALL MPUADR (JV,NS,N,JSW)
      IF(JSW.GT.2) GO TO 140
      NS=0
      LEVS=3
      GO TO 110
      END
[\].
K@@@@@SRC
C.MPAOPT (K)
      SUBROUTINE MPAOPT
C+    NAM: MPAOPT  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: CROSS-ASSMEBLER OPTION DIRECTIVE SCAN ROUTINE
C
C     SYS: M68SAM
C
C     ENT: N/A
C     RTN: N/A
C
C     FNC: SCAN THE 'OPT' OPERAND FIELD AN SET THE REQUESTED
C          OPTIONS FOUND 1=> NO, 2=>YES.
C*
      INTEGER JPT(3)
      COMMON ICOMON(5),ICSHF,IA2SHF(452),NAM(4),ISIMBF(44),NC
      COMMON ICSW,IPASS(19),NOPT(2),NOPC(4),NOPCL,IXBASE,LSPSP
      COMMON L8SP,L10,L16,LSP(14),LN,LO
      EQUIVALENCE (N1,NAM(1)),(N2,NAM(2)),(N3,NAM(3))
      EQUIVALENCE (NOPBAS,NOPT(1))
      DATA KC1000/4096/,KC800/2048/
100   IANS=2
      IF(NC.NE.LN) GO TO 110
C***  'N' OR 'NO' => TURN THE OPTION OFF
      IANS=1
      CALL MPUGNC(NC)
      IF(NC.EQ.LO) CALL MPUGNC(NC)
110   CALL MPUBNM(NAM)
C***  LOOK-UP THE OPTION
      DO 120I=1,NOPCL,2
      IF(N1.EQ.NOPC(I).AND.N2.EQ.NOPC(I+1)) GO TO 180
120   CONTINUE
      N=N1/ICSHF
      DO 130I=1,NOPCL,2
      IF(N.EQ.NOPC(I)/ICSHF) GO TO 180
130   CONTINUE
C***  ERROR '217' UNDEFINED OPTION OR SYNTAX IN OPTION FORMAT
140   CALL MPAERR (217)
150   GO TO (170,160,165,100,165,170),ICSW
C***  SKIP TO START OF THE NEXT FIELD
160   CALL MPUGNC(NC)
      GO TO 150
165   CALL MPUGNC (NC)
      GO TO 140
180   NOPCMD=I/2+1
      IF(NOPCMD.EQ.1) GO TO 190
      NOPT(NOPCMD)=IANS
      GO TO 150
C***  CHANGE DISPLAY NUMBER BASE
190   N=N2
      IF(N3.NE.LSPSP) N=N3
      I=8
      IF(N.EQ.L8SP) GO TO 210
      IF(N.EQ.L10) GO TO 200
      IF(N.NE.L16) GO TO 140
      I=I+6
200   I=I+2
210   NOPBAS=I
      IXBASE=I/5
      GO TO 150
170   RETURN
      END
[\].
L@@@@@SRC
C.MPAPAG (L)
C
C  27 JUL 76 (PDH) RE-DO THE INITIALIZATION FOR RSX
C   2 MAR 76 (PDH) TIDY UP INITIALIZATION AND LINE COUNTING
C  18 FEB 76 (PDH) CHANGE 'JPVFCC' TO 'PVFCC'
C
      SUBROUTINE MPAPAG (JNL)
C+    NAM: MPAPAG  VER: 1.1  DAT: 04-18-75  CMP: ALL
C
C     SYS: M68SAM
C
C     ENT: JNL - 0 GO TO TOP OF PAGE
C              - >0 NUMBER OF LINES PRINTED
C
C     RTN: JNL - N/C
C
C     FNC: COUNT EACH LINE PRINTED AND GO TO TOP OF THE
C          PAGE EACH TIME WHEN THE PAGE OVERFLOWS.
C
C     REV: N/A
C*
      INTEGER INAME(6)
      REAL PNAME(3)
      COMMON ICOMON,LULT,LUSI(365),NPNAM(3),NPGNO,IPGLOL,IPGLEN
      COMMON NPLCT,IOTBUF(153),NOPT(2)
      EQUIVALENCE (NOPLI,NOPT(2))
      EQUIVALENCE (INAME(1),PNAME(1))
      DATA PVFCC/1H1/
C
      IF(NOPLI.EQ.1) RETURN
      IF (JNL) 240,250,230
230   NPLCT=NPLCT+JNL
      IF (NPLCT-IPGLEN) 280,280,250
C
C  INITIALIZE HEADER ON PAGE 1
C
240   NPGNO = 0
C
C***  PAGE OVERFLOW, GO TO TOP OF THE NEXT PAGE
C
250   NPGNO=NPGNO+1
      DO 251 I=1,3
      K = I*2 - 1
      INAME(K) = NPNAM(I)
251   CONTINUE
      WRITE (LULT,299) PVFCC,PNAME,NPGNO
260   DO 270 I=1,3
      WRITE (LULT,298)
270   CONTINUE
      NPLCT=4
280   RETURN
298   FORMAT (1H )
299   FORMAT (A2,3A2,9X,30HMOTOROLA M6800 CROSS-ASSEMBLER,9X,4HPAGE,I3)
      END
[\].
M68...002
	.TITLE	M68...
/
/   9 MAR 78 (002; PDH) FORGOT THE LITERAL AFTER 'GC4'
/  31 JAN 78 - PAUL HENDERSON
/
/  MAINLINE FOR THE MOTOROLA CROSS ASSEMBLER.  THIS MAINLINE IS
/  NECESARY IF THE CROSS ASSEMBLER IS TO BE USED AS A TDV FUNCTION.
/  UNDER MULTIACCESS, THIS IS THE ONLY PRACTICAL WAY TO PROCEED.
/  THIS HAS SIMILAR INVOCATION AND LUN USAGE TO THE PDP-15 ASSEMBLER.
/     AT PRESENT THE LUN'S HAVE THE FOLLOWING USE:
/
/	13 - ERROR MESSAGES
/	15 - SOURCE FILE INPUT FOR PASS 1
/	16 - LISTING OUTPUT
/	17 - OBJECT FILE OUTPUT
/	18 - INTERNAL CODE OUTPUT ON PASS 1 FOR INPUT AT PASS 2
/
/  COMMAND STRING:
/
/	M89 O_NAME1,NAME2, . . .
/
/  WHERE 'O' IS PRESENTLY NOT RECOGNIZED, BUT WOULD BE 'B' &/OR 'L'.
/	 NAME1,NAME2 ARE FILE NAMES OF THE PROGRAMS TO BE ASSEMBLED.
/		THE FILE NAMES MAY BE ONLY 5 CHARACTERS MAXIMUM, AND
/		THE EXTENSION MUST BE 'SRC'
/
IDX=ISZ
/
	.GLOBL	M6800,PACK
/
	.EJECT
M68...	CAL	XFRCMD		/ GET COMMAND LINE
	CAL	WAITFR
	LAC	(CMDLIN+2
	DAC	CHPNT		/ SET UP THE CHARACTER GETTER
	LAC	(G1
	DAC	DSPCH
/
GC1	JMS	GETCHR		/ FLUSH COMMAND STRING THROUGH
	SAD	(40		/ FIRST SPACE
	JMP	GC2
	JMP	GC1
/
GC2	JMS	GETCHR		/ NOW FLUSH EXTRA SPACES
	SAD	(40
	JMP	GC2
/
/  AT THIS POINT ONE WOULD CHECK FOR OPTIONS.  THE PRESENT IMPLEMENTATION
/  ALWAYS GENERATES 'B,L,S'.  THE DELIMITER '_' IS REQUIRED.
/
	SAD	(137		/ '_' OPTION DELIMITER?
	JMP	GC3
	JMP	GC2		/ FLUSH CHARACTERS BEFORE DELIMITER
/
	.EJECT
GC3	CLX
	LAC	(5
	PAL
	DZM	NAME,X		/ CLEAR FILE NAME BUFFER
	AXS	1
	JMP	.-2
	LAW	-1		/ WE SET XR TO -1 BECAUSE WE
	PAX			/ 'AXS' BEFORE WE 'DAC NAME,X'.
/
GC4	JMS	GETCHR		/ GET CHARACTERS AND CHECK FOR
	SAD	(54		/ COMMA
	CLA
	SAD	(15		/ CARRIAGE RETURN		/(002)
	LAW	-1
	SAD	(175		/ AND ALT MODE
	LAW	-1
	DAC	EXITFL		/ SAVE FOR LATER CHECK
	SPA!SNA			/ SPA&SNA
	JMP	GOTNAM		/ NEGATIVE OR ZERO MEANS END OF FILE NAME
	AXS	1
	DAC	NAME,X		/ STORE ONLY FIRST 5 CHARACTERS
	JMP	GC4
/
GOTNAM	LAC	(NAME
	DAC	PCK+1		/ SET UP THE 'PACK' ROUTINE
	DAC	PCK+2
PCK	JMS*	PACK		/ PACK UP THE FILE NAME
	0; 0
	JMS*	M6800		/ GO AND ASSEMBLE THE
	JMP	.+2
	NAME			/ SPECIFIED FILE.
	LAC	EXITFL		/ DO WE HAVE MORE FILE TO ASSEMBLE?
	SMA
	JMP	GC3		/ YES.  GO AND DO IT.
	CAL	(10		/ NO.  EXIT THE TASK.
/
	.EJECT
/  THIS ROUTINE WAS WRITTEN TO EXTRACT CHARACTERS FROM THE COMMAND
/  LINE.  IT WAS WRITTEN SO THAT NO ASSUMPTIONS ARE MADE ABOUT THE CONTENTS
/  OF THE MQ, BECAUSE WE DO NOT KNOW WHEN THE END OF FILE NAME WILL
/  BE ENCOUNTERED, AND THIS ROUTINE MUST BE READY TO PICK UP THE
/  CHARACTER GETTING AT ANY POINT.
/
GETCHR	XX
	JMP*	DSPCH
/
DSPCH	G1
	AND	(177		/ TRIM TO 7-BITS AND
	JMP*	GETCHR		/ LEAVE WITH CHARACTER IN AC
/
G1	LAC*	CHPNT		/ 1ST CHARACTER
	LRS	13
	JMS	DSPCH
G2	LAC*	CHPNT
	LRS	4
	JMS	DSPCH
G3	LAC*	CHPNT
	IDX	CHPNT
	DAC	DSPCH		/ TEMPORARILY SAVE 1ST HALF
	LAC*	CHPNT
	LMQ			/ 2ND HALF GOES IN MQ
	LAC	DSPCH
	LLS	3
	JMS	DSPCH
G4	LAC*	CHPNT
	LRS	10
	JMS	DSPCH
G5	LAC*	CHPNT
	IDX	CHPNT
	RAR
	JMS	DSPCH
	JMP	G1
/
NAME	.BLOCK	5
CMDLIN	.BLOCK	42;	.ASCII	<15>; .LOC .-1
EV;CHPNT;EXITFL
XFRCMD	37;	EV;	CMDLIN; 42
WAITFR	20;	EV
	.END	M68...
[\].
M6809@015
	.TITLE	M6809
/
/  21 MAR 78 (015; PDH) MUST WAIT AFTER 'HINF' IN SUBROUTINE 'READ'
/  17 MAR 78 (014; PDH) ERROR MESSAGES IN 'READ' GO TO LUN 13
/  11 MAR 78 (013; PDH) ADD ENTRY POINT 'RSREAD' FOR MULTIPLE ASEMBLIES.
/   6 MAR 78 (011; PDH) MAKE SURE CHECKSUM WORD IN 'PCHBUF' IS ZERO
/  31 JAN 78 (010; PDH) MAKE CHANGES IN 'READ' FOR MULTIACCESS
/   7 OCT 76 (009; PDH) THROW AWAY LINE FEEDS IN SUBROUTINE READ
/  26 JUL 76 (007: PDH) CONDITIONALIZE FOR RSX
/   1 JUN 76 (006: PDH) ADD CONDITIONAL ASSEMBLY FOR DOS
/  24 FEB 76 (PDH) ADD SUBROUTINE 'READ' FOR CARD INPUT
/  19 FEB 76 (PDH) ADD NEW ROUTINE 'PNCHR1' FOR PAPER TAPE
/  18 FEB 76 (PDH) RETRO-FIT TO DEC FORTRAN
/  13 FEB 76 (PDH) INCLUDE 'MPUBSM', 'MPUCA1', 'MPUCA2', 'MPUCVC',
/		'MPUNEG', 'MPUOVF', 'MPUXBS', 'MPUXBY'
/  12 FEB 76 - PAUL HENDERSON:  'IAND'
/
/  THIS PACKAGE IS A GROUP OF SUPPORTING ROUTINES FOR
/  THE PROGRAM 'M6800', THE CROSS-ASSEMBLER FOR THE M6800
/  MICRO-PROCESSOR.  THESE ROUTINES ARE INTENDED TO REPLACE
/  SELECTED SUBROUTINES AND FUNCTIONS IN AN EFFORT TO INCREASE
/  THE SPEED OF THE CROSS-ASSEMBLER.
/
/  TO ASSEMBLE FOR DEC FORTRAN, THE SYMBOL 'F4=1' MUST BE DEFINED.
/  TO ASSEMBLE FOR DEC FORTRAN ON THE PDP-15, THE SYMBOL
/  'DOS=1' MUST BE DEFINED.L  TO ASSEMBLE FOR USE UNDER RSX,
/  THE SYMBOL
/
RSX=1		/ MUST BE DEFINED.  THIS AUTOMATICALLY
/
/  DEFINES 'DOS' AND 'F4'.
/
IDX=ISZ			/ INDEX POINTER, SKIP NOT INTENDED
SET=ISZ			/ SET A FLAG TO A NON-ZERO VALUE
/
	.EJECT
/  GLOBALS AND COMMON ROUTINES:
/
	.IFDEF	RSX
DOS=1
	.ENDC
	.IFDEF	DOS
F4=1
	.ENDC
	.IFUND	F4
	.GLOBL	.ARG,.INT1,.INT2,.MODEA
/
	.DEFIN	PUTINT
	JMS	SETINT
	.ENDM
/
/  THE FOLLOWING IS A SUBROUTINE COMMON TO ALL INTEGER FUNCTIONS
/  TO SET THE INTEGER ACCUMULATOR.
/
SETINT	XX
	DZM*	.INT1		/ ZERO MOST SIGNIFICANT WORD
	DAC*	.INT2		/ RETURN THE VALUE TO LEAST SIGNIFICANT
	DZM*	.MODEA		/ INDICATE MODE OF RESULT IS INTEGER
	JMP*	SETINT
	.ENDC
/
	.IFDEF	F4
	.GLOBL	.DA
.ARG=.DA
/
	.DEFIN	PUTINT
	.ENDM			/ ASSEMBLES NOTHING
	.ENDC
/
	.TITLE	FUNCTION IAND (A,B)
/
/  FUNCTION TO PERFORM THE LOGICAL 'AND' OPERATION BETWEEN
/  THE TWO ARGUMENTS.
/
/  CALLING SEQUENCE:
/
/	INTEGER A,B,C
/	 - - -
/	C = IAND (A,B)
/	 - - -
/
	.GLOBL	IAND
/
IAND	XX
	JMS*	.ARG
	JMP	.+3
A
B
	LAC*	A
	AND*	B
	PUTINT			/ STORE RESULT IN INTEGER ACCUMULATOR
	JMP*	IAND
/
	.TITLE	FUNCTION MPUBSM (JWD,JSB,JMK)
/
/  FUNCTION TO SHIFT AND MASK BITS.  THE ORIGINAL FORTRAN CODING
/  CALLED FUNCTION 'MPUXBS', BUT THIS IMPLEMENTATION USES ITS OWN
/  ABBREVIATED VERSION OF 'MPUXBS'.
/
	.GLOBL	MPUBSM
/
MPUBSM	XX
	JMS*	.ARG
	JMP	.+4
JWD
JSB
JMK
	LAW	-1
	TAD*	JSB
	AND	(77
	XOR	(LRSS		/ BUILD SHIFT INSTRUCTION OF CORRECT VALUE
	DAC	SHIFT2
	LAC*	JWD		/ GET WORD TO BE SHIFTED
SHIFT2	XX			/ SHIFT IT.
	AND*	JMK
	PUTINT			/ RETURN THE VALUE
	JMP*	MPUBSM
/
	.TITLE	SUBROUTINE MPUCA1 (JLST,JN)
/
/  SUBROUTINE TO CONVERT AN ARRAY FROM THE INTERNAL R1 FORMAT
/  TO A1 FORMAT.
/
/  ENT:	JLST - ARRAY IN R1 FORMAT TO BE CONVERTED
/	JN   - NUMBER OF WORDS TO BE CONVERTED
/
/  RTN:	JLST - ARRAY CONVERTED TO A1 FORMAT
/	JN   - N/C
/
	.GLOBL	MPUCA1
/
MPUCA1	XX
	JMS*	.ARG
	JMP	.+3
JLST
JN
	LAW	-1
	TAD*	JN
	CMA
	DAC	JN		/ HANDY PLACE TO USE AS A COUNTER
	.IFUND	DOS
	.IFDEF	F4
	LAC*	JLST		/ MUST FETCH DOUBLE INDIRECT
	DAC	JLST
	.ENDC
	.ENDC
CA1L	LAC*	JLST		/ GET WORD IN 'R1'
	ALSS	13		/ CONVERT TO 'A1'
	DAC*	JLST		/ REPLACE IN ARRAY
	IDX	JLST		/ POINT TO NEXT WORD
	ISZ	JN
	JMP	CA1L
	JMP*	MPUCA1
/
	.TITLE	SUBROUTINE MPUCA2 (JLST2,JN2)
/
/  SUBROUTINE TO CONVERT AN ARRAY FROM THE INTERNAL R2 FORMAT
/  TO A2 FORMAT.
/
/  ENT:	JLST2 - ARRAY IN R2 TO BE CONVERTED
/	JN2   - NUMBER OF WORDS TO BE CONVERTED
/
/  RTN:	JLST2 - ARRAY CONVERTED TO A2 FORMAT
/	JN2   - N/C
/
	.GLOBL	MPUCA2
/
MPUCA2	XX
	JMS*	.ARG
	JMP	.+3
JLST2
JN2
	LAW	-1
	TAD*	JN2
	CMA
	DAC	JN2
	.IFUND	DOS
	.IFDEF	F4
	LAC*	JLST2		/ MUST FETCH DOUBLE INDIRECT FOR F4
	DAC	JLST2
	.ENDC
	.ENDC
CA2L	LAC*	JLST2		/ GET WORD IN 'R2'
	LMQ
	LLSS	13
	RCR			/ NOW HAVE 7-BIT ASCII IN AC11 - MQ6
	LLSS	13		/ CONVERT TO 'A2'
	DAC*	JLST2		/ REPLACE IN ARRAY
	IDX	JLST2
	ISZ	JN2
	JMP	CA2L
	JMP*	MPUCA2
/
	.TITLE	SUBROUTINE MPUCVC (JW,JC)
/
/  SUBROUTINE TO CONVERT A SINGLE CHARACTER
/  FROM A1 TO R1 FORMAT
/
/  ENT:	JW - WORD IN A1 FORMAT
/	JC - N/A
/
/  RTN:	JW - N/C
/	JC - CHARACTER CONVERTED TO R1 FORMAT
/
	.GLOBL	MPUCVC
/
MPUCVC	XX
	JMS*	.ARG
	JMP	.+3
JW
JC
	LAC*	JW		/ GET 'A1' CHARACTER
	CLL
	LRS	13		/ CONVERT TO 'R1'
	DAC*	JC		/ RETURN TO CALLER
	JMP*	MPUCVC
/
	.TITLE	SUBROUTINE MPUNEG (JNBR)
/
/  SUBROUTINE TO CONVERT A NUMBER TO ITS 2'S COMPLEMENT, 16 BIT FORM,
/  IF IT IS NEGATIVE.
/
	.GLOBL	MPUNEG
/
MPUNEG	XX
	JMS*	.ARG
	JMP	.+2
JNBR
	LAC*	JNBR
	SMA
	JMP*	MPUNEG		/ RETURN IF POSITIVE
	.DEC
	TAD	(65536
	.OCT
	DAC*	JNBR
	JMP*	MPUNEG
/
	.TITLE	SUBROUTINE MPUOVF (JNBRO,JOVF)
/
/  SUBROUTINE TO TEST FOR OVERFLOW IN 16-BIT NUMBER, AND
/  TRUNCATE TO 16-BIT RESULT, IF OVERFLOW.
/
/  ENT:	JNBRO - NUMBER TO BE TESTED FOR OVERFLOW
/	JOVF  - FUNCTION TO PERFORM
/		1 - RESET OVERFLOW INDICATOR
/		2,3, ETC - TEST FOR OVERFLOW
/
/  RTN:	JNBRO - NUMBER, ADJUSTED TO 16-BIT REPRESENTATION, IF NECESSARY
/	JOVF  - 0: NO OVERFLOW
/		1: OVERFLOW
/
	.GLOBL	MPUOVF
/
MPUOVF	XX
	JMS*	.ARG
	JMP	.+3
JNBRO
JOVF
	LAC*	JOVF		/ GET FUNCTION CODE
	DZM*	JOVF
	SAD	(1		/ IS IT THE 'RESET' FUNCTION?
	JMP*	MPUOVF		/ YES.
/
	LAC*	JNBRO		/ GET NUMBER TO BE TESTED
	SPA
	JMP	TSTNEG		/ NEGATIVE NUMBERS GET SPECIAL ATTENTION
	AND	(600000
	SNA			/ TEST FOR OVERFLOWED BITS
	JMP*	MPUOVF		/ NO OVERFLOW
	IDX*	JOVF		/ SET OVERFLOW INDICATOR
	LAC*	JNBRO
	AND	(17777		/ CHOP TO 16 BITS
	DAC*	JNBRO
	JMP*	MPUOVF
/
TSTNEG	CMA
	TAD	(1
	DAC	JWORD		/ SAVE POSITIVE VALUE
	AND	(600000
	SNA			/ TEST FOR OVERFLOWED BITS
	JMP*	MPUOVF
	IDX*	JOVF		/ SET OVERFLOW INDICATOR
	LAC	JWORD		/ RETRIEVE NUMBER
	AND	(17777
	CMA
	TAD	(1
	DAC*	JNBRO		/ RETURN ADJUSTED VALUE
	JMP*	MPUOVF
/
	.TITLE	FUNCTION MPUXBS (JWORD,JMSB,JLSB)
/
/  FUNCTION TO EXTRACT A BIT STRING FROM A SPECIFIED WORD.
/  THE RESULTING BIT STRING IS RIGHT-ADJUSTED.
/
/  ENT:	JWORD - WORD FROM WHICH TO EXTRACT BIT STRING
/	JMSB  - BIT NUMBER OF MSB
/	JLSB  - BIT NUMBER OF LSB
/
/  RTN:	JWORD - N/C
/	JMSB  - N/C
/	JLSB  - N/C
/
/  NOTE:  BIT 16 (OR 18) IS MSB.  BIT 1 IS LSB.
/
	.GLOBL	MPUXBS
/
MPUXBS	XX
	JMS*	.ARG
	JMP	.+4
JWORD
JMSB
JLSB
	LAW	-1
	TAD*	JLSB
	AND	(77		/ IN CASE CALLER IS INCORRECT
	XOR	(LRSS		/ DETERMINE HOW FAR TO SHIFT 'JWORD'
	DAC	SHIFT
	LAW	-2
	TAD*	JLSB
	CMA
	TAD*	JMSB		/ THIS DETERMINES HOW MANY BITS IN THE
	AND	(77		/ MASK TO BE APPLIED AFTER THE SHIFT
	XOR	(LLSS
	DAC	MASK
	CLQ!CMQ!1000		/ CLEAR AC, SET MQ=-1
MASK	XX			/ SHIFT IN PROPER NUMBER OF MASK BITS
	DAC	MASK		/ SAVE MASK
	LAC*	JWORD		/ GET WORD FROM WHICH WE ARE TO
SHIFT	XX			/ EXTRACT THE BIT STRING
	AND	MASK		/ SELECT ONLY DESIRED PORTION
	PUTINT			/ RETURN THE RESULT
	JMP*	MPUXBS
/
	.TITLE	SUBROUTINE MPUXBY (JWRDBY,JBYTE1,JBYTE2)
/
/  SUBROUTINE TO EXTRACT UPPER AND LOWER BYTES FROM A WORD
/
/  ENT:	JWRDBY - WORD FROM WHICH BYTES ARE TO BE EXTRACTED
/	JBYTE1 - N/A
/	JBYTE2 - N/A
/
/  RTN:	JWRDBY - N/C
/	JBYTE1 - UPPER BYTE OF 'JWRDBY' (RIGHT ADJUSTED)
/	JBYTE2 - LOWER BYTE OF 'JWRDBY' (RIGHT ADJUSTED)
/
	.GLOBL	MPUXBY
/
MPUXBY	XX
	JMS*	.ARG
	JMP	.+4
JWRDBY
JBYTE1
JBYTE2
	LAC*	JWRDBY
	LRSS	10		/ MOVE UPPER BYTE TO AC 10-17
	DAC*	JBYTE1
	LLSS!1000 10		/ CLEAR UPPER BYTE AND SHIFT LOWER BYTE BACK
	DAC*	JBYTE2
	JMP*	MPUXBY
/
	.TITLE	SUBROUTINE PNCHR1 (LUOT,IOTBUF,IOTINX)
/
/  SUBROUTINE TO PUNCH AABUFFER PRESENTLY STORED IN 'R1' FORMAT.  THIS
/  IS THE SAME AS IMAGE ASCII MODE.
/
/  ENT:	LUOT   - LOGICAL UNIT (.DAT) FOR PUNCH
/	IOTBUF - INTEGER ARRAY CONTAINING THE ASCII IN 'R1'
/	IOTINX - NUMBER OF CHARACTERS IN ARRAY
/
/  RTN:	LUOT   - N/C
/	IOTBUF - MAY HAVE <15> AFTER THE "IOTINX'TH" CHARACTER
/	IOTINX - N/C
/
/  COMMENT: BECAUSE THE COMMON AREAS ARE ARRANGED IN THE CALLING
/  PROGRAM SO THAT 'IOTINX' IMMEDIATELY FOLLOWS 'IOTBUF(80)', IT
/  IS POSSIBLE THAT  THE  APPENDED  CARRIAGE  RETURN  WILL  FALL
/  ON 'IOTINX'.   FOR THIS REASON,  'IOTINX'  WILL  BE SAVED AND
/  RESTORED AFTER THE ARRAY IS PACKED UP INTO 5/7 ASCII.
/
	.GLOBL	PNCHR1,PACK
/
PNCHR1	XX
	JMS*	.ARG
	JMP	.+4
LUOT
IOTBUF
IOTINX
	LAC*	LUOT		/ GET .DAT SLOT NUMBER
	.IFUND	RSX
	DAC	WAITPP		/ ' .WAIT LUOT'
	XOR	(2000
	.ENDC
	DAC	WRPP		/ ' .WRITE LUOT,2, . , .
	.IFUND	DOS
	.IFDEF	F4
	LAC*	IOTBUF
	DAC	IOTBUF		/ DOUBLE INDIRECT FOR DEC FORTRAN
	.ENDC
	.ENDC
	LAC*	IOTINX
	DAC	LUOT		/ SAVE VALUE FOR LATER RESTORATION
	TAD	IOTBUF
	DAC	JWORD		/ POINTS TO 'IOTBUF(IOTINX+1)'
	LAW	15
	DAC*	JWORD		/ APPEND CARRIAGE RETURN TO END OF LINE
	LAC	IOTBUF
	DAC	PCK+1		/ FIX UP POINTERS FOR 'PACK'
	LAC	(PCHBUF+2
	DAC	PCK+2
/
	.EJECT
	.IFDEF	RSX
	CAL	WTP		/ WAIT IN CASE I/O STILL UNDERWAY
	.ENDC
	.IFUND	RSX
WAITPP	.WAIT	0		/ IN CASE PREVIOUS I/O STILL UNDERWAY
	.ENDC
PCK	JMS*	PACK
	0; 0
	SMA!CLC
	JMP	PCK
	TAD	(PCHBUF						/(012)
	CMA							/(012)
	TAD	PCK+2
	ALSS	10		/ WORD PAIR COUNT FOR HEADER
	XOR	(2		/ IOPS ASCII
	DAC	PCHBUF
	.IFDEF	RSX
	CAL	WRITEP
	.ENDC
	.IFUND	RSX
WRPP	.WRITE	0,2,PCHBUF,0
	.ENDC
	LAC	LUOT
	DAC*	IOTINX		/ RESTORE 'IOTINX' IN CASE OF CLOBBER
	JMP*	PNCHR1
/
PCHBUF	0; 0; .LOC PCHBUF	/ CHECKSUM WORD MUST BE ZERO	/(011)
	.BLOCK	120/5*2+4
/
	.IFDEF	RSX
EVPP	1		/ INITIALLY 1 SO THE 1ST WAIT FALLS THROUGH
WTP	20;	EVPP		/ CPB FOR WAIT ON PUNCH
WRITEP	2700;	EVPP;WRPP; 2; PCHBUF
	.ENDC
	.TITLE	RSREAD						/(013)
/
/  SUBROUTINE TO RESET THE 'READ' ROUTINE SO THAT MULTIPLE ASSEMBLIES
/  FROM THE SAME TDV COMMAND STRING CAN BE PROCESSED.  WITHOUT SOME
/  MEANS OF RESETTING THE ROUTINE, ONLY THE STRING ' END' WILL BE
/  RETURNED AFTER THE FIRST ASSEMBLY.  THIS IS CONSIDERED TO BE
/  SOMEWHAT LESS THAN DESIREABLE.
/
	.GLOBL	RSREAD
/
RSREAD	XX							/(013)
	LAC	(NOP						/(013)
	DAC	SETUP		/ ENABLE THE SETUP SECTION	/(013)
	JMP*	RSREAD						/(013)
	.TITLE	SUBROUTINE READ (ISIBUF,LUSI)
/
/  SUBROUTINE TO DOUBLE BUFFER THE SOURCE INPUT.  WHEN END OF FILE
/  IS ENCOUNTERED, THE STRING ' END' IS RETURNED TO THE CROSS
/  ASSEMBLER.
/
/  ENT:	ISIBUF - N/A
/	LUSI   - FIRST TIME ONLY, SET UP '.INIT', ETC
/		- AFTER FIRST TIME, N/A
/
/  RTN:	ISIBUF - ARRAY OF UP TO 80 CHARACTERS IN 'A1' FORMAT
/	LUSI   - N/C
/
	.GLOBL	READ
/
READ	XX
	JMS*	.ARG
	JMP	SETUP
ISIBUF
LUSI
SETUP	NOP						/(013)
	LAC*	LUSI		/ GET .DAT NUMBER
	DAC	INITCD		/ .INIT LUSI,0
	DAC	WAITCD		/ .WAIT LUSI
	.IFUND	RSX
	DAC	SEEKCD		/ .SEEK LUSI, . . .
	XOR	(2000
	DAC	READC1		/ .READ LUSI,2, . . .
	.ENDC
	DAC	READCD
	.IFDEF	RSX
	CAL	HINF		/ FIND OUT ABOUT INPUT HANDLER
	CAL	WAITR						/(015)
	LAC	EVCD		/ GET RETURNED STATUS
	SPA!RAL
	JMP	HNFERR		/ 'HINF ERROR'
	SMA!RTL			/ IS IT AN INPUT DEVICE?
	JMP	DEVERR		/ CANNOT INPUT FROM INPUT DEVICE!
	SMA			/ IS DEVICE DIRECTORIED?
	CAL	ATTACH		/ NOT DIRECTORIED.  ATTACH DEVICE.
/
READC1	CAL	READC		/ READ 1ST CARD
	LAC	BYPASS
	DAC	SETUP		/ BYPASS SETUP AFTER 1ST TIME.
BYPASS	JMP	WAITC
/
	.EJECT
WAITC	CAL	WAITR		/ WAIT FOR INPUT TO BE READY.
	.ENDC
	.IFUND	RSX
INITCD	.INIT	0,0
SEEKCD	.SEEK	0,NAMEIN	/ 'MP6800 INP'
READC1	.READ	0,2,ILINE,34	/ READ FIRST CARD
	LAC	BYPASS
	DAC	SETUP		/ BYPASS SETUP AFTER 1ST TIME
BYPASS	JMP	WAITCD
/
WAITCD	.WAIT	0		/ WAIT FOR PREVIOUS INPUT TO FINISH
	.ENDC
	.IFUND	DOS
	.IFDEF	F4
	LAC*	ISIBUF		/ PERFORM DOUBLE INDIRECT FOR DEC FORTRAN
	DAC	ISIBUF
	.ENDC
	.ENDC
	LAC	ILINE
	AND	(7
	SAD	(2		/ CHECK FOR END-OF-FILE
	SKP
	JMP	READ3		/ END-OF-FILE EXIT
	LAC	(ILINE+1
	DAC	FPOINT		/ POINT AT LINE JUST READ IN
	JMP	G4
/
READ2	LAC*	FPOINT		/ GET PACKED WORD OF CHARACTERS
	JMP*	GET2		/ DISPATCH TO CORRECT SPOT
/
GET2	XX
	AND	(774000		/ TRIM TO 'A1' FORMAT
	SAD	LF
	JMP	READ2		/ IGNORE LINE FEEDS
	SAD	CR		/ IS IT END OF LINE
	JMP	READ4
	DAC*	ISIBUF		/ STORE CHARACTER AWAY
	IDX	ISIBUF
	JMP	READ2
/
	.EJECT
G4	IDX	FPOINT		/ INDEX TO NEXT CHARACTER
	LAC*	FPOINT		/ GET 1ST CHARACTER
	JMS	GET2
	LLS	7		/ 2ND CHARACTER
	JMS	GET2
	DAC	GET2		/ SAVE 1ST HALF OF 3RD CHARACTER
	IDX	FPOINT
	LAC*	FPOINT
	LMQ
	LAC	GET2		/ RETRIEVE 1ST HALF
	LRS	4
	LACQ			/ 3RD CHARACTER
	JMS	GET2
	LLS	3		/ 4TH CHARACTER
	JMS	GET2
	LLS	12		/ 5TH CHARACTER
	JMS	GET2
	JMP	G4
/
READ3	SET	ENDFIL		/ SET END-OF-FILE MARKER
	LAC	(END-1
	DAC	FPOINT		/ PREPARE TO RETURN ' END'
	JMP	G4
/
READ4	LAC	ENDFIL		/ CHECK FOR END-OF-FILE
	SZA
	JMP*	READ		/ DO NOT READ NEXT LINE IF END-OF-FILE
	.IFDEF	RSX
	CAL	READC		/ READ NEXT CARD
	.ENDC
	.IFUND	RSX
READCD	.READ	0,2,ILINE,34	/ READ NEXT LINE
	.ENDC
/
	.EJECT
	JMP*	READ
ILINE	.BLOCK	42
CR	.ASCII	<15> ; .LOC .-1
LF	.ASCII	<12> ; .LOC .-1
END	.ASCII	' END'<15>
	.IFDEF	RSX
HNFERR	LAC	MSG1+1		/ GET APPROPRIATE MESSAGE ADDRESS
	SKP
DEVERR	LAC	MSG2+1
	DAC	ERRBP		/ PUT IN ERROR BUFFER POINTER
	CAL	ERRCPB		/ ANNOUNCE ERROR ON MCR TERMINAL
	CAL	ERWAIT		/ WAIT FOR IT TO FINISH
	CAL	(10		/ THEN EXIT.
/
ERRCPB	2700;	EVERR; 13; 2;ERRBP				/(014)
ERWAIT	20;	EVERR
EVERR
MSG1	5002; MSG1
	.ASCII	'M6800: HINF ERROR'<15>
MSG2	5002; MSG2
	.ASCII	'M6800: CANNOT INPUT FROM INPUT DEVICE!'<15>
EVCD
WAITR	20;	EVCD
HINF	3600;	EVCD;INITCD
ATTACH	2400;	EVCD;WAITCD
READC	2600;	EVCD;READCD; 2; ILINE; 42
	.ENDC
	.IFUND	RSX
NAMEIN	.SIXBT	'M6800@INP'
	.ENDC
FPOINT;ENDFIL
	.END
[\].
M@@@@@SRC
C.MPAPA1 (M)
      SUBROUTINE MPAPA1 (JPSW,JBUF,JLEN)
C+    NAM: MPAPA1  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: PRINT BUFFER IN 'A1' FORMAT
C
C     SYS: M68SAM
C
C     ENT: JPSW - 1=> DONOT PRINT
C               - 2=> PRINT
C          JBUF - BUFFER TO PRINT
C          JLEN - MAX NUMBER OF CHARACTERS IN JBUF
C
C     RTN: JPSW - N/C
C          JBUF - BUFFER CONVERTED TO COMPUTER'S A1 FORMAT
C          JLEN - N/C
C
C     FNC: CONVERT THE BUFFER FROM SYSTEM'S R1 FORMAT TO
C          THE COMPUTER'S A1 FORMAT AND THEN PRINT ONLY
C          THE NON-SPACES (SKIP TRAILING BLANKS).
C*
      INTEGER JBUF(140),IJBUF(280)
      COMMON ICOMON,LULT,LUSI(2),LLSPSP
      COMMON /DECF4/ RBUF(140)
      EQUIVALENCE (RBUF(1),IJBUF(1))
      CALL MPUCA1 (JBUF,JLEN)
      DO 10 I=1,JLEN
      L = JLEN - I + 1
      IF (JBUF(L) .NE. LLSPSP) GO TO 101
10    CONTINUE
101   DO 102 I=1,L
      K = I*2 - 1
      IJBUF(K) = JBUF(I)
102   CONTINUE
      WRITE (LULT,11) (RBUF(I),I=1,L)
11    FORMAT (140A1)
      RETURN
      END
[\].
MPU@@@JOB
$JOB 73 T=15 UFD=RK1<MPU>
$MSG ASSEMBLE, COMPILE, AND TASK BUILD MOROTOLA CROSS-ASSEMBLER
 $FOR BR_F,H
$FOR BR_A,B,C,D,E,F,G,H,I,J,K,L,M
$FOR BR_N,O,P,Q,R,S,T,U,V,W,X,Y,Z
$MAC BREF_MPURSX PRM,M6809 015
$MAC ERB_M68... 002
$TKB
NRM,UL:DUMMY}
M68...}
350}
TDV
 }
M68...,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,
Q,R,S,T,U,V,W,X,Y,Z,M6809
 }
 }
 
$END
[\].
MPURSXPRM
RSX=1
	.EOT
[\].
N@@@@@SRC
C.MPAPRL (N)
      SUBROUTINE MPAPRL (JDOSW)
C+    NAM: MPAPRL  VER: 1.1  DAT: 04-18-75  CMP: ALL
C     PGM: PRINT AND OUTPUT THE SOURCE LIST
C
C     SYS: M68SAM
C
C      ENT: JDOSW - PRINT AND OUTPUT FUNCTION AS BIT SETTING:
C                   1)  1=> LINE NUMBER
C                   2)  2=> P COUNTER
C                   3)  4=> OPCODE
C                   4)  8=> OPERAND 1
C                   5) 16=> OPERAND 2
C                   6) 32=> STATEMENT
C                   7) 64=> DATA BYTE 1
C                   8) 128=> DATA BYTE 2
C                   9) 256=> OUTPUT BINARY CODE
C                  10) 512=> PRINT IN PASS ONE
C
C     RTN: JDOSW - N/C
C
C     FNC: PRINT THE SOURCE LINE AS THE SETTING OF 'JDOSW'
C          AND THEN OUTPUT BINARY CODE TO THE MEMORY FILE.
C*
      INTEGER JLDF(6),JSDF(6),JSSDF(3)
      COMMON ICOMON(5),ICSHF,IA2SHF(231),NB(121),INX,LABEL(5)
      COMMON IOPCOD(3),NPNAM(4),IPGLOL,IPGLEN(90),ISIMBF(43),IC
      COMMON NC,ICSW,IPASS,IOPCLS(2),IOPBIN,IOPAN1,IPCT,ITERR
      COMMON NRTSW,NSSCOL,NSOSCH,NAMSW(9),NOPT(2),NOPC(5)
      COMMON IXBASE,LSPSP(4),LSP
      EQUIVALENCE (ISILN,ISIMBF(2)),(NOPBAS,NOPT(1))
      EQUIVALENCE (NOPLI,NOPT(2))
      DATA JLDF(1)/3/,JLDF(2)/3/,JLDF(3)/2/,JLDF(4)/6/,JLDF(5)/5/
      DATA JLDF(6)/4/,JSDF(1)/14/,JSDF(2)/13/,JSDF(3)/12/,JSDF(4)/18/
      DATA JSDF(5)/17/,JSDF(6)/15/
      DATA JSSDF(1)/25/,JSSDF(2)/23/,JSSDF(3)/20/
      DATA K1/1/,K2/2/,K5/5/,K10/10/
C
      JPP1SW=MPUBSM(JDOSW,K10,K1)
      IF(JPP1SW.EQ.0.AND.IPASS.EQ.1) RETURN
      JDSW=JDOSW
      GO TO (350,100),NOPLI
100   DO 110I=1,IPGLOL
      NB(I)=LSP
110   CONTINUE
      DO 340N=1,8
      I=IAND(JDSW,K1)
      JDSW=JDSW/2
      IF (I.EQ.0) GO TO 340
      I=0
      K=0
      J=IOPAN1
      GO TO (120,130,140,160,150,200,180,170),N
C***  FORMAT THE LINE NUMBER
120   INX=1
      CALL MPUCNA (ISILN,K10,K5)
      GO TO 340
C***  FORMAT THE P COUNTER (ADR)
130   K=3
      INX=7
      J=IPCT
      GO TO 190
C***  FORMAT THE OPCODE
140   J=IOPBIN
      GO TO 180
C***  FORMAT OPERAND 2
150   K=3
C***  FORMAT OPERAND 1
160   I=3
      GO TO 180
C***  FORMAT DATA BYTE 2
170   K=3
C***  FORMAT DATA BYTE 1
180   I=I+IXBASE
      INX=JSDF(I)
190   K=K+IXBASE
      I=JLDF(K)
      CALL MPUCNA (J,NOPBAS,I)
      GO TO 340
C
C***  MOVE THE STATEMENT TO THE PRINT BUFFER
C
200   INX=JSSDF(IXBASE)
      JSIX=INX
      ISIC=IC-1
      IC=0
      IF(NRTSW.EQ.1) GO TO 310
C***  MOVE THE LABEL FIELD
210   CALL MPUGNC(NC)
      IF(IC.LT.7) CALL MPUSNC(NC)
      IF(ICSW.EQ.1.OR.ICSW.EQ.6) GO TO 220
      GO TO 210
C***  FORMAT THE OPCODE
220   IF(INX-JSIX.LT.7) INX=JSIX+7
      I=IOPCOD(1)/ICSHF
      CALL MPUSNC(I)
      I=IOPCOD(1)-I*ICSHF
      CALL MPUSNC(I)
      I=IOPCOD(2)/ICSHF
      CALL MPUSNC(I)
      INX=INX+1
      I=IOPCOD(2)-I*ICSHF
      CALL MPUSNC(I)
C***  FIND THE START OF THE NEXT FIELD
      IC=NSSCOL-1
      LEVS=0
230   INX=INX+2
240   LEVS=LEVS+1
250   CALL MPUGNC(NC)
260   GO TO (270,280,280,270,300),LEVS
270   IF(ICSW.EQ.1) GO TO 250
      IF(ICSW.EQ.6) GO TO 330
      LEVS=LEVS+1
      GO TO 260
280   IF(NRTSW.EQ.2) GO TO 300
C***  MOVE THE OPERAND FIELD
      IF(INX.GE.IPGLOL) GO TO 330
      CALL MPUSNC(NC)
      IF(NRTSW.NE.4) GO TO 290
C***  OPCODE 'FCC N,'
      NSOSCH=NSOSCH-1
      IF(NSOSCH.EQ.0) GO TO 230
      GO TO 250
290   IF(LEVS.EQ.2) GO TO 240
      IF(NSOSCH.EQ.NC) GO TO 230
      GO TO 250
C***  MOVE THE COMMENT FIELD
300   IF(INX-JSIX.LT.23) INX=JSIX+23
      IC=IC-1
310   L=IPGLOL-INX
      DO 320I=1,L
      CALL MPUGNC(NC)
      CALL MPUSNC(NC)
320   CONTINUE
330   IC=ISIC
      CALL MPUGNC(NC)
340   CONTINUE
C***  PRINT THE LINE
      CALL MPAPA1 (K2,NB,IPGLOL)
      CALL MPAPAG(K1)
C
C***  STORE THE INSTRUCTION IN THE TAPE FILE
C
350   IF(JPP1SW.EQ.1) GO TO 380
      JDSW=JDOSW
      IF(MPUBSM(JDSW,9,1).EQ.0) GO TO 380
      JADR=IPCT
      IF(MPUBSM(JDSW,3,1).EQ.0) GO TO 360
      CALL MPUPTS (K2,JADR,IOPBIN)
      JADR=JADR+1
360   JV=IOPAN1
      IF(MPUBSM(JDSW,4,9).EQ.0) GO TO 370
      IF(JV.LT.0) JV=256-IABS(JV)
      CALL MPUPTS (K2,JADR,JV)
      GO TO 380
370   IF(MPUBSM(JDSW,5,9).EQ.0) GO TO 380
      CALL MPUNEG(JV)
      CALL MPUXBY(JV, JV1, JV2)
      CALL MPUPTS (K2,JADR,JV1)
      JADR=JADR+1
      CALL MPUPTS (K2,JADR,JV2)
380   RETURN
      END
[\].
O@@@@@SRC
C.MPAPSC (O)
      SUBROUTINE MPAPSC
C+    NAM: MPAPSC  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: DIRECTIVE OPCODES DECODE
C
C     SYS: M68SAM
C
C     ENT: N/A
C     RTN: N/A
C
C     FNC: DIRECTIVE OPCODE PROCCESSOR
C*
      COMMON ICOMON(359),LABEL(4),LABESW,IOPCOD(9),NPLCT
      COMMON IOTBUF(131),IC,NC,ICSW,IPASS,IOPCLS,IOPIXB,IOPBIN
      COMMON IOPAN1,IPCT,ITERR,NRTSW,NSSCOL,NSOSCH
      I=IOPIXB-4
C***  * * *  PAG ORG EQU FCB FCC FDB RMB SPC OPT
      GO TO (250,100,130,170,190,220,240,260,280),I
C
C***  'ORG' ASSIGN PROGRAM COUNTER
C
100   CALL MPAOPR (IOPAN1,JOPRSW)
      IF(JOPRSW.GT.2) GO TO 120
      IPCT=IOPAN1
      JDOSW=35
      GO TO 310
C***  ERROR '216' SYNTAX ERROR IN DIRECTIVE'S OPERAND
120   CALL MPAERR (216)
      CALL MPAPRL (35)
      RETURN
C
C***  'EQU' EQUATE SYMBOL
C
130   CALL MPAFSY (LABEL,I,J)
      IF(I.NE.1.AND.IPASS.EQ.1) RETURN
      CALL MPAOPR (IOPAN1,JOPRSW)
      IF(JOPRSW.LT.3.AND.I.EQ.1) GO TO 140
C***  '213' NO LABEL, SYNTAX OR REDEFINED EQU DIRECTIVE
      CALL MPAERR (213)
C***  SET THE SYMBOL'S ERROR CODE BIT
135   CALL MPASSY (LABEL,3,I)
      GO TO 150
140   GO TO (145,150),IPASS
C***  STORE THE SYMBOL VALUE (NO STORE IF SYMBOL IS IN ERR)
145   IF(LABESW.EQ.2.AND.LABEL(4).NE.IOPAN1) GO TO 135
      LABEL(4)=IOPAN1
      CALL MPASSY (LABEL,2,LABESW)
      RETURN
C***  PRINT THE SOURCE LINE
150   CALL MPAPRL (161)
      RETURN
C
C***  'FCB' FORM CONSTANT BYTE
C
170   I=355
180   CALL MPAOPR (IOPAN1,JOPRSW)
      GO TO (185,182),IPASS
C***  ERROR '210' BYTE OVERFLOW (> 255)
182   IF(JOPRSW.EQ.2.OR.JOPRSW.EQ.3) CALL MPAERR (210)
C***  ERROR '214' SYNTAX ERROR IN FCB DIRECTIVE
      IF(JOPRSW.EQ.5) CALL MPAERR (214)
      CALL MPAPRL(I)
      I=322
185   IPCT=IPCT+1
      IF(ICSW.NE.2) RETURN
      CALL MPUGNC(NC)
      GO TO 180
C
C***  'FCC' FORM CONSTANT CHARACTERS
C
190   JSIC=IC
      NSOSCH=NC
      CALL MPUFNO(JV,I)
      IF(JV.EQ.0.AND.I.EQ.2.OR.ICSW.NE.2) GO TO 200
C***  'FCC N,TEXT'
      IF(I.NE.1.OR.JV.GT.255.OR.JV.LT.1) GO TO 120
      NRTSW=4
      NS0SCH=JV+IC+1-JSIC
      JSIC=IC
C***  'FCC /TEXT/'
200   I=355
      IC=JSIC
210   CALL MPUGNC(IOPAN1)
      IF(NRTSW.NE.4.AND.ICSW.EQ.6.OR.IOPAN1.EQ.NSOSCH) RETURN
      CALL MPAPRL(I)
      I=322
      IPCT=IPCT+1
      IF(NRTSW.NE.4) GO TO 210
      JV=JV-1
      IF(JV.EQ.0) RETURN
      GO TO 210
C
C***  'FDB' FORM DOUBLE CONSTANT BYTE
C
220   I=419
230   CALL MPAOPR(IOPAN1,JOPRSW)
      GO TO (235,232),IPASS
C***  ERROR '215' SYNTAX ERROR IN FDB DIRECTIVE
232   IF(JOPRSW.EQ.3.OR.JOPRSW.EQ.5) CALL MPAERR (215)
      CALL MPAPRL(I)
      I=386
235   IPCT=IPCT+2
      IF(ICSW.NE.2) RETURN
      CALL MPUGNC(NC)
      GO TO 230
C
C***  'RMB' RESERVE MEMORY BYTES
C
240   CALL MPAOPR (IOPAN1,JOPRSW)
      IF(JOPRSW.GT.2) GO TO 120
      CALL MPAPRL(163)
      IPCT=IPCT+IOPAN1
      RETURN
C
C
C***  'PAGE' PLACE PAGE AT TOP OF THE NEXT PAGE (PASS 2 ONLY)
C
250   IF(IPASS.EQ.1) GO TO 300
      IF(NPLCT.GT.8) CALL MPAPAG(0)
      GO TO 300
C
C***  'SPC' SPACE 'N' LINES
C
260   CALL MPAOPR (JV,JOPRSW)
      IF(JOPRSW.GT.2) GO TO 120
C***  STOP SPACING AT THE TOP OF A PAGE OR WHEN COUNT = 0
270   IF(JV.LT.1.OR.NPLCT.LT.5) GO TO 300
      CALL MPAPRL (0)
      JV=JV-1
      GO TO 270
C
C***  'OPT' OPTION RECORD
C
280   CALL MPAOPT
      JDOSW=33
      GO TO 310
C***  CHECK FOR LABEL ON DIRECTIVES WHICH SHOULD NOT HAVE ANY
300   JDOSW=0
310   IF(LABEL(1).EQ.0) GO TO 320
C***  ERROR '223' DIRECTIVE SHOULD NOT HAVE A LABEL
      CALL MPAERR (223)
      LABEL(4)=0
      CALL MPASSY (LABEL,2,I)
      CALL MPASSY (LABEL,3,I)
      IF(JDOSW.EQ.0) JDOSW=33
320   IF(JDOSW.NE.0) CALL MPAPRL (JDOSW)
      RETURN
      END
[\].
P@@@@@SRC
C.MPASSY (P)
      SUBROUTINE MPASSY (JNAM,JDSW,JRSW)
C+    NAM: MPASSY  VER: 1.0  DAT: 10-01-74  CMP: ALL
C     PGM: STORE INTO THE SYMBOL TABLE
C
C     SYS: M68SAM
C
C
C     ENT: JNAM - 4 WORD SYMBOL TO STORE
C               - WORDS 1 TO 3 SYMBOL IN SYSTEM'S R2 FORMAT
C               - WORD 4 SYMBOL'S VALUE
C          JDSW - 1 => STORE THE SYMBOL
C               - 2 => FIND THE SYMBOL AND CHANGE WORD 4
C               - 3 => SET THE SYMBOL'S DEFINATION ERROR FLAG
C          JRSW - N/A
C
C     RTN: JNAM - N/C
C          JDSW - N/C
C          JRSW - 1 => OPERATION COMPLETED OK
C               - 2 => SYMBOL IS IN THE SYMBOL TABLE
C               - 3 => ERROR, ERROR CODE BIT SET, SYMBOL TABLE
C                      OVERFLOW, OR ENDEFINE SYMBOL (JDSW 2&3)
C
C     FNC: SEARCH THE SYMBOL TABLE FOR THE SYMBOL AND THEN
C          STORE THE SYMBOL OR CHANGE IT'S VALUE OR SET
C          IT'S ERROR FLAG.
C*
      INTEGER JNAM(4)
      COMMON ICOMON(26),KC7F7F,KCFFFF,KC80,KEATB(531),NOSYM
      COMMON ISYM(813),LSYM
      JRSW=1
      JV=JNAM(4)
      CALL MPAFSY (JNAM,J,I)
      GO TO (100,200,300),JDSW
C***  STORE THE SYMBOL INTO THE SYMBOL TABLE
100   GO TO (102,400,105),J
C***  SYMBOL IS IN THE TABLE
102   IF(ISYM(I+3).EQ.JV) RETURN
      JRSW=2
      RETURN
C***  THE SYMBOL IS NOT IN THE TABLE
105   IF(I+4.LT.LSYM) GO TO 110
C***  ERROR '221' SYMBOL TABLE OVERFLOW
      CALL MPAERR (221)
      GO TO 400
C***  STORE THE SYMBOL
110   NOSYM=NOSYM+1
      ISYM(I)=JNAM(1)
      ISYM(I+1)=JNAM(2)
      ISYM(I+2)=JNAM(3)
      ISYM(I+4)=0
120   ISYM(I+3)=JV
      RETURN
C***  CHANGE THE SYMBOL'S VALUE (WORD 4)
200   IF(J.EQ.1) GO TO 120
C***  SYMBOL IS IN ERROR OR NOT IN THE TABLE
      GO TO 400
C***  SET THE SYMBOL'S ERROR FLAG
300   IF(J.EQ.3) GO TO 400
      ISYM(I)=IAND(ISYM(I),KC7F7F)+KC80
      RETURN
400   JRSW=3
      RETURN
      END
[\].
Q@@@@@SRC
C.MPUADR (Q)
      SUBROUTINE MPUADR(JP1, JS, JP2, JSW)
C+    NAM: MPUADR  VER: 1.1  DAT: 03-18-75  CMP: ALL
C     PGM: 16 BIT 2'S COMPLEMENT ADDER
C
C     SYS: ALL
C
C     ENT: JP1 - OPERAND 1
C          JS  - FUNCTION TO PERFORM
C                1 => ADD
C                2 => SUBTRACT
C                3 => MULTIPLY
C                4 => DIVIDE
C          JP2 - OPERAND 2
C          JSW - N/A
C
C     RTN: JP1 - RESULT OF OPERATION
C          JS  - N/C
C          JP2 - N/C
C          JSW - STATUS OF OPERATION
C                1 => 8 BITS
C                2 => 16 BITS
C                3 => OVERFLOW
C
C     FNC: PERFORMS REQUESTED ARITHMETIC FUNCTION AND DETERMINES
C          BIT SIZE OF RESULT.  16 BIT OVERFLOW IS CHECKED.
C
C     REV: 1.1 - FIXED 16-BIT ARITH PROBLEM
C*
      COMMON ICOMON(8),IBPWD
      DATA K1/1/
C
C***  RESET OVERFLOW INDICATOR
C
      CALL MPUOVF(JP1,K1)
      JSW = 1
      JOVF = 2
C
C***  ADDER FOR MACHINES WITH WORDSIZE > 16 BITS.
C
100   GO TO (110, 120, 130, 140), JS
110   JP1 = JP1 + JP2
      GO TO 150
120   JP1 = JP1 - JP2
      GO TO 150
130   JP1 = JP1*JP2
      JOVF=3
      GO TO 150
140   JP1 = JP1/JP2
150   IF (IABS(JP1) .GE. 256) JSW = 2
C
C***  TEST FOR OVERFLOW
C
160   CALL MPUOVF(JP1, JOVF)
      IF (JOVF .NE. 0) JSW = 3
      RETURN
      END
[\].
R@@@@@SRC
C.MPUBNM (R)
      SUBROUTINE MPUBNM (JNAM)
C+    NAM: MPUBNM  VER: 1.0  DAT: 12-29-73  CMP: ALL
C     PGM: P#
C
C     SYS: ALL
C
C     ENT: N/A
C
C     RTN: N/A
C
C     FNC:
C     GEN:
C
C     REV: N/A
C*
      INTEGER JNAM(3)
      COMMON ICOMON(506),NC,ICSW,IPASS(27),LSPSP,L8SP(3),LSP
C
C     BUILD 1 TO 6 CHARACTER ALPHA NUMERIC SYMBOL
C     SYMBOL MUST START WITH A ALPHA CHAR 'A' - 'Z'
C
      DO 10 I=1,3
10    JNAM(I)=LSPSP
      I=1
      IF(ICSW.EQ.4) GO TO 30
      RETURN
20    CALL MPUGNC (NC)
      IF(ICSW.LT.3.OR.ICSW.GT.4) RETURN
30    JC=NC*256
      JNAM(I)=JC+LSP
      CALL MPUGNC (NC)
      IF(ICSW.LT.3.OR.ICSW.GT.4) RETURN
      JNAM(I)=JC+NC
      I=I+1
      IF(I.LT.4) GO TO 20
C     SKIP TO THE END OF THE SYMBOL
40    CALL MPUGNC (NC)
      IF(ICSW.LT.3.OR.ICSW.GT.4) RETURN
      GO TO 40
      END
[\].
S@@@@@SRC
C.MPUCNA (S)
      SUBROUTINE MPUCNA(JN,JBAS,JCOL)
C+    NAM: MPUCNA  VER: 1.3  DAT: 03-18-75  CMP: ALL
C     PGM: CONVERT BINARY NUMBER TO ASCII
C
C     SYS: ALL
C
C     ENT: JN  -BINARY NUMBER TO BE CONVERTED
C          JBAS-BASE TO USE IN CONVERSION
C          JCOL-NUMBER OF COLUMNS OF CONVERTED OUTPUT
C
C     RTN: JN  -N/C
C          JBAS-N/C
C          JCOL-N/C
C
C     FNC: ROUTINE CONVERTS BINARY INTEGER TO ASCII OUTPUT IN
C          THE REQUESTED BASE.  ASCII OUTPUT IS PLACE IN ARRAY
C          "NB" BY ROUTINE MPUSNC.
C
C     REV: 1.1 - ROUTINE WAS MADE MACHINE INDEPENDENT
C          1.2 - FIX CODE FOR 1.1 CHANGE
C          1.3 - IMPLEMENTED MPVMUL/MPVDIV ROUTINES
C*
      INTEGER ID(6)
      COMMON ICOMON(8),IBPWD,KCFOTB(18),KCFFFF,KC80(517),L0
      NN = IAND(JN, KCFFFF)
C
C***  CONVERSION FOR MACHINES WITH WORDSIZE > 16 BITS
C
20    DO 30 I = 1, JCOL
      J=NN/JBAS
      ID(I)=NN-(J*JBAS)
      NN=J
30    CONTINUE
40    I = JCOL
50    NN = ID(I)
      IF(NN.GT.9) NN=NN+7
      CALL MPUSNC (NN+L0)
      I=I-1
      IF(I.GT.0) GO TO 50
      RETURN
      END
[\].
T@@@@@SRC
C.MPUFNO (T)
      SUBROUTINE MPUFNO (JN,JER)
C+    NAM: MPUFNO  VER: 1.2  DAT: 03-18-75  CMP: ALL
C     PGM: FORM A INTEGER NUMBER FROM THE IMAGE BUFFER
C
C     SYS: ALL
C
C     ENT: JN  - N/A
C          JER - N/A
C
C     RTN: JN  - INTEGER NUMBER THAT WAS SCANNED FROM THE BUFFER
C          JER - 1 => NO ERROR, OK
C              - 2 => SYNTAX ERROR IN THE NUMBER OR THE BASE
C                     SELECT CHAR WAS NOT %, @ OR $
C
C
C     FNC: THE ROUTINE WILL START THE SCAN AT THE PRESENT CHAR
C          IN THE 'NC' BUFFER AND SCAN OUT THE NEXT INTEGER
C          NUMBER. THE NUMBER MAYBE IN BASE BINARY, OCTAL,
C          DECIMAL OR HEX. SEE FORMAT. THE SCAN WILL STOP AT
C          THE NEXT NON-NUMERIC CHAR. THE CHAR WILL BE RETURNED
C          IN THE 'NC' BUFFER.
C
C     GEN: FORMAT:
C          %N OR NB => BINARY (N = 0-1)
C          @N NQ OR NO => OCTAL (N = 0-7)
C           N OR ND => DECIMAL (N = 0-9)
C          $N OR 0NH => HEX (N = 0-9 OR A-F)
C
C     REV: 1.1 - BASE CHAR WITHOUT A DIGIT ARE FLAGGED AS ERRORS
C          1.2 - FIXED 16-BIT ARITH PROBLEM
C*
      INTEGER JNB(4)
      COMMON ICOMON(506),NC,ICSW,IPASS(14),LSBH,LSBO,LSBB
      COMMON LSPCT(20),L0,L1(2),LA,LB,LD,LF,LH,LN,LO,LQ
      EQUIVALENCE (JNB(1),JN2),(JNB(2),JN8)
      EQUIVALENCE (JNB(3),JN10),(JNB(4),JN16)
      JSB=0
      DO 90 N=1,4
      JNB(N)=0
90    CONTINUE
      JER=2
      JNSB=1
      LEVS=1
      GO TO 110
100   CALL MPUGNC (NC)
110   JNCSW=1
      GO TO (120,190),LEVS
C***  * * *   SP  ,  0-9 A-Z SPC END
120   GO TO (140,140,180,140,130,140),ICSW
130   JSB=1
      IF(NC.EQ.LSBH) GO TO 150
      IF(NC.EQ.LSBO) GO TO 160
      IF(NC.EQ.LSBB) GO TO 170
C***  ILLEGAL CHAR IN THE NUMBER FIELD
140   JN=0
      JER=2
      RETURN
150   JSB=JSB+2
160   JSB=JSB+1
170   LEVS=2
      GO TO 100
C***  BUILD NUMBER (LEVEL 2)
180   LEVS=2
190   GO TO (300,300,200,250,300,300),ICSW
C***  CHAR IS '0' TO '9'
200   N=NC-L0
      GO TO (210,220,230,240),JNSB
210   IF(N.GT.1) JNSB=2
      JN2 = JN2*2 + N
220   IF(N.GT.7) JNSB=3
      JN8 = JN8*8 + N
230   IF(N.GT.9) JNSB=4
      JN10 = JN10*10 + N
240   JN16 = JN16*16 + N
      JER=1
      GO TO (100,110),JNCSW
C***  CHAR IS 'A' TO 'Z'
250   JC=NC
      JNCSW=2
      CALL MPUGNC(NC)
      IF(JC.GT.LF) GO TO 260
      N=JC-LA+10
      IF(JNSB.EQ.4) GO TO 240
      IF(JC.NE.LB.AND.JC.NE.LD.OR.JSB.NE.0) GO TO 230
      IF(ICSW.EQ.3.OR.ICSW.EQ.4) GO TO 230
260   JSB=1
      IF(JC.EQ.LB) GO TO 290
      IF(JC.EQ.LQ.OR.JC.EQ.LO) GO TO 280
      IF(JC.EQ.LD) GO TO 270
      IF(JC.NE.LH) GO TO 140
      JSB=JSB+1
270   JSB=JSB+1
280   JSB=JSB+1
290   IF(ICSW.EQ.3.OR.ICSW.EQ.4) GO TO 140
C***  END OF THE NUMBER FIELD
300   IF(JSB.NE.0) GO TO 310
      JSB=3
      IF(JNSB.EQ.4) JSB=4
310   IF(JSB.LT.JNSB) GO TO 140
      JN=JNB(JSB)
      RETURN
      END
[\].
U@@@@@SRC
C.MPUGNC (U)
      SUBROUTINE MPUGNC (JC)
C+    NAM: MPUGNC  VER: 1.1  DAT: 08-12-74  CMP: ALL
C     PGM: GET NEXT CHARACTER FROM IMAGE BUFFER
C
C     SYS: ALL
C
C     ENT: JC - N/A
C
C     RTN: JC - NEXT CHARACTER FORM THE IMAGE BUFFER
C
C     FNC: GET THE NEXT CHARACTER AND RETURN IT IN 'NC' AND 'JC'
C          ALSO SET 'ICSW' FOR TYPE OF CHARACTER. 'IC=IC+1'
C
C     GEN: ICSW IS SET AS FOLLOWS FOR THE CHARACTER RETURNED:
C          ICSW IS SET TO)
C          1 => SPACE ' '
C          2 => COMMA ','
C          3 => '0' - '9'
C          4 => 'A' - 'Z'
C          5 => SPECIAL CHAR
C          6 => END OF STATEMENT
C          NOTE: IF THE CHAR. IS NOT WITHIN 20 TO 60 HEX ICSW=1
C
C     REV: 1.1 - TRAILING SPACES ARE NOT RETURNED
C*
      INTEGER IMAGE(40)
      COMMON ICOMON(5),ICSHF,IA2SHF(456),ISIMBF(43),IC,NC,ICSW
      COMMON IPASS(31),LSP,LASK(2),LCOMA,LMNS(2),L0,L1,L9,LA
      COMMON LB(10),LZ
      EQUIVALENCE (IMAGE(1),ISIMBF(4))
      IF(IC.LE.ISIMBF(1)*2-6) GO TO 10
      NC=LSP
      JC=LSP
      ICSW=6
      RETURN
10    I=IC/2
      IW=IMAGE(I+1)
      I=IC-I*2
      IC=IC+1
      NC=IW/ICSHF
      IF(I.NE.0) NC=IW-(NC*ICSHF)
      JC=NC
      IF(NC.NE.LSP) GO TO 20
C***  CHAR IS A ' ' (SPACE)
15    ICSW=1
      RETURN
20    IF(NC.NE.LCOMA) GO TO 30
C***  CHAR IS A ',' (COMMA)
      ICSW=2
      RETURN
30    IF(NC.LT.L0.OR.NC.GT.L9) GO TO 40
C***  **   CHAR IS '0' - '9'
      ICSW=3
      RETURN
40    IF(NC.LT.LA.OR.NC.GT.LZ) GO TO 50
C***  CHAR IS 'A' - 'Z'
      ICSW=4
      RETURN
50    IF(NC.LT.LSP.OR.NC.GT.95) GO TO 15
      ICSW=5
      RETURN
      END
[\].
V@@@@@SRC
C.MPUPIB (V)
      SUBROUTINE MPUPIB (JB,JLSW)
C+    NAM: MPUPIB  VER: 1.4  DAT: 03-18-75  CMP: ALL
C     PGM: PACK SOURCE IMAGE BUFFER
C
C     SYS: ALL
C
C     ENT: JB   - 80 WORD BUFFER IN COMPUTER'S A1 FORMAT TO BE
C                 CONVERTED AND PACKED
C          JLSW - 1 => NO LINE NUMBERS IN THE BUFFER
C               - 2 => LINE NUMBER IN THE BUFFER
C
C     RTN: JB   - N/C
C                 'JB' WAS NOT WITHIN THE RANGE '0' TO '9'
C          JLSW - SET TO 1 IF THE 1ST CHARACTER OF THE BUFFER
C
C     FNC: CONVERT THE BUFFER 'JB' FROM THE COMPUTER'S A1
C          FORMAT AND THEN REMOVE THE LINE NUMBER IF IT HAS
C          ONE (CONVERTING IT TO BINARY) AND PACKING THE BUFFER
C          INTO THE SYSTEM'S R2 FORMAT. THE OUTPUT IS A PACKED
C          'ISIMBF(43)' BUFFER IN THE FOLLOWING FORMAT:
C
C          WORD 1 NUMBER OF WORDS+3 TO END OF TEXT (TRAILING
C                 SPACES ARE NOT INCLUDED).
C          WORD 2 BINARY LINE NUMBER OF THE RECORD
C          WORD 3 1ST CHARACTER IN SYSTEM'S R1 FORMAT IF THE
C                 RECORD'S LINE NUMBER WAS NOT FOLLOWED BY A
C                 SPACE. OTHER WISE IT IS A SPACE.
C          WORDS 4 TO 43 ARE THE TEXT OF THE RECORD IN SYSTEM'S
C                 R2 FORMAT.
C
C     GEN: THE 1ST CHARACTER IS RETURN BY A CALL TO 'MPUGNC'
C          AFTER THE BUFFER IS PACKED UP. THE 1ST CHARACTER
C          AFTER THE LINE NUMBER IS CHARACTER 1 IF IT IS NOT
C          A SPACE, OTHERWISE IT IS THE 2ND ONE
C
C     REV: 1.1 - 1ST CHAR RETURNED IN 'ISIMBF(3)'
C          1.2 - IF NO LINE 'ISILN' IS NOT CHANGED, MPURA1
C                PLACES THE LINE NUMBER IN 'ISILN'
C          1.3 - BLANK LINE WILL BE 2 SPACE LONG
C          1.4 - FIX 16-BIT ARITH PROBLEM
C*
      INTEGER JB(80)
      COMMON ICOMON(4),LLSPSP,ICSHF,IA2SHF(456),ISIMBF(43),IC
      COMMON NC,ICSW(28),LSPSP,L8SP(3),LSP,LASK(5),L0,L1,L9
      EQUIVALENCE (ISILN,ISIMBF(2))
      CALL MPUCVC (JB(1),JC)
      IF(JC.LT.L0.OR.JC.GT.L9) JLSW=1
      ISIMBF(3)=LSP
      IF(JLSW.EQ.2) ISIMBF(3)=JC
      JULSW=1
      N=0
      J=3
      ISIMBF(1)=4
      DO 200 I=1,80
      JC=LSP
      JW=JB(I)
      IF(JW.NE.LLSPSP) CALL MPUCVC (JW,JC)
      GO TO (120,160,170),JULSW
120   GO TO (160,140),JLSW
C***  BUILD THE LINE NUMBER
140   IF(JC.LT.L0.OR.JC.GT.L9) GO TO 150
      N = N*10 + (JC - L0)
      GO TO 200
C***  SAVE THE LINE NUMBER AND THE 1ST CHAR. AFTER IT
150   ISILN=N
      ISIMBF(3)=JC
      IF(JC.EQ.LSP) GO TO 180
160   J=J+1
      ISIMBF(J)=JC*ICSHF+LSP
      JULSW=3
      GO TO 190
170   ISIMBF(J)=ISIMBF(J)-LSP+JC
180   JULSW=2
C***  SAVE THE END OF IMAGE INDEX
190   IF(JC.NE.LSP) ISIMBF(1)=J
200   CONTINUE
C***  SPACE FILL THE REMAINING PART OF THE BUFFER
210   J=J+1
      IF(J.GT.43) GO TO 220
      ISIMBF(J)=LSPSP
      GO TO 210
C***  GET THE 1ST CHARACTER AND RETURN IT
220   IC=0
      CALL MPUGNC(NC)
      RETURN
      END
[\].
W@@@@@SRC
C.MPUPTS (W)
C
C   6 MAR 78 (PDH) INCLUDE 'K0' IN DATA STATEMENT
C  31 JAN 78 (PDH) OUTPUT ASCII CODE 33 (ESC) WITH INITIALIZATION.
C   3 FEB 77 (PDH) CHANGE INITIAL LINE TO DISPLAY A DIRECTION ARROW
C   1 JUN 76 (PDH) CHANGE BLANK LINE TO 'L  ' FOR REMOTE LOADING
C  19 FEB 76 (PDH) OUTPUT BLANK LINE TO 'LUOT' TO INITIALIZE DEVICE
C
      SUBROUTINE MPUPTS (JDSW,JADR,JBYT)
C+    NAM: MPUPTS  VER: 1.0  DAT: 09-15-74  CMP: ALL
C     PGM: MEMORY OUTPUT TO PAPER TAPE FILE SETUP ROUTINE
C
C     SYS: ALL
C
C     ENT: JDSW - 1=> OPEN THE ROUTINE
C               - 2=> STORE BYTE INTO PT BUFFER
C               - 3=> CLOSE THE ROUTINE
C          JADR - IF JDSW=2, ADDRESS OF THE BYTE TO STORE
C          JBYT - IF JDSW=2, BYTE TO STORE AT ADDRESS JADR
C
C     RTN: JDSW - N/C
C          JADR - N/C
C          JBYT - N/C
C
C     FNC: THIS ROUTINE IS USE TO SETUP AND THEN OUTPUT
C          ONE BYTE AT A TIME TO THE 'IOTBUF' BUFFER
C          THE ROUTINE WILL OUTPUT THE RECORD WHEN IT IS FULL
C          AND ALSO CHANGE BYTE ADDRESSES IF THE NEXT
C          ADDRESS IS NOT EQUAL TO 'JADR'. THE LAST CALL
C          (JDSW=3) WILL OUTPUT THE LAST RECORD AND END OF
C          P.T. FILE RECORD (S9).
C
C     REV: N/A
C*
      COMMON ICOMON(3),LUOT,LLSPSP(451),IOTSW,IOTCKS,NOTADR,NAM(87)
      COMMON L0,L1,L9,LA(2),LD,LF,LH,LN(3),LR
C
C  THE FOLLOWING IS SOME GAME PLAYING TO OUTPUT CODE '33' (ESC)
C  FROM THE FORTRAN PROGRAM.  THE VALUE 55296 IS ASCII 33(OCTAL) IN A1
C
      EQUIVALENCE (ESC,IESC)
      DATA IESC/55296/
C
      DATA K0/0/,K1/1/,K2/2/,K3/3/,K4/4/
C
      GO TO (100,200,300),JDSW
C
C***  OPEN THE ROUTINE BY OUTPUTTING 'HDR' RECORD
C
100   WRITE (LUOT,101) ESC
101   FORMAT (' @@@@@@@@@@DFMDDDDD@@@@@@@@@@L',A1)
      CALL MPUPTW (K1,L0)
      CALL MPUPTW (K2,K0)
      CALL MPUPTW (K3,LH)
      CALL MPUPTW (K3,LD)
      CALL MPUPTW (K3,LR)
      CALL MPUPTW (K4,K0)
      RETURN
C
C***  STORE THE BYTE INTO THE P.T. BUFFER
C
200   GO TO (220,210),IOTSW
C***  RECORD CONTAINS PART OF A RECORD
210   IF(JADR.EQ.NOTADR.AND.IAND(NOTADR,15).NE.0) GO TO 230
C***  OUTPUT THE LAST RECORD
      CALL MPUPTW (K4,K0)
C***  START OF A NEW RECORD
220   NOTADR=JADR
      CALL MPUPTW (K1,L1)
      CALL MPUPTW (K2,NOTADR)
C***  SET THE 'OT' BUFFER SW 2=> BUFFER CONTAINS A RECORD
      IOTSW=2
C***  STORE THE BYTE INTO THE P.T. RECORD BUFFER
230   CALL MPUPTW (K3,JBYT)
      NOTADR=NOTADR+1
      RETURN
C
C***  CLOSE THE ROUTINE, OUTPUT THE 'S9' RECORD
C
300   IF(IOTSW.NE.1) CALL MPUPTW (K4,K0)
      CALL MPUPTW (K1,L9)
      CALL MPUPTW (K2,K0)
      CALL MPUPTW (K4,K0)
      RETURN
      END
	.EOT
C***  START OF A NEW RECORD
220   NOTADR=JADR
      CALL MPUPTW (K1,L1)
      CALL MPUPTW (K2,NOTADR)
C***  SET THE 'OT' BUFFER SW 2=> BUFFER CONTAINS A RECORD
      IOTSW=2
C***  STORE THE BYTE INTO THE P.T. RECORD BUFFER
230   CALL MPUPTW (K3,JBYT)
      NOTADR=NOTADR+1
      RETURN
C
C***  CLOSE THE ROUTINE, OUTPUT THE 'S9' RECORD
C
300   IF(IOTSW.NE.1) CALL MPUPTW (K4,K0)
      CALL MPUPTW (K1,L9)
      CALL MPUPTW (K2,K0)
      CALL MPUPTW (K4,K0)
      RETURN
      END
[\].
X@@@@@SRC
C.MPUPTW (X)
C
C  19 FEB 76 (PDH) CONVERT TO NEW ROUTINE 'PNCHR1' FOR PAPER TAPE
C
      SUBROUTINE MPUPTW (JSW,JAD)
C+    NAM: MPUPTW  VER: 1.2  DAT: 04-18-75  CMP: ALL
C     PGM: BUILD AND WRITE OUT PAPER TAPE FILE RECORDS
C
C     SYS: ALL
C
C     ENT: JSW - 1=> INITIALIZE, 'LX' WHERE: X IS JAD
C              - 2=> STORE P.T. RECORD'S 1ST BYTE ADDRESS
C              - 3=> STORE 8 BIT BYTE
C              - 4=> END OF RECORD, OUTPUT IT
C          JAD - CHAR, ADDRESS OR BYTE TO BE STORED IN THE
C                P.T. FILE RECORD.
C
C     RTN: JSW - N/C
C          JAD - N/C
C
C     FNC: BUILD A P.T. FILE RECORD A BYTE AT A TIME AND
C          OUTPUT THE RECORD TO THE 'OT' FILE.
C
C     REV: 1.0 - JCKSUM CHANGED TO ITOCKS AND IS IN COMMON
C          1.1 - FIX FOR 16-BIT ARITH PROBLEMS
C          1.2 - ADDED 2 LEADING SPACES TO EACH OT RECORD
C*
      COMMON ICOMON(3),LUOT,LLSPSP(21),KCFF,KC7F7F(211),NB(121)
      COMMON INX,LABEL(15),IOTBUF(80),IOTINX,IOTSW,IOTCKS
      COMMON NOTADR(100),LS
      DATA K2/2/,K16/16/
      GO TO (100,200,300,400),JSW
C***  INITIALIZE THE BUFFER WITH 'SX'
100   IOTBUF(1)=LS
      IOTBUF(2)=JAD
      RETURN
C***  STORE THE ADDRESS OF THE 1ST BYTE OF THE RECORD
200   IOTCKS = JAD/256 + IAND(JAD, KCFF)
      L=4
      IOTINX=4
      GO TO 310
C***  STORE THE NEXT BYTE IN THE RECORD
300   IOTCKS=IOTCKS+JAD
      L=2
310   INX=0
      CALL MPUCNA (JAD,K16,L)
      DO 320 J=1,L
      IOTINX=IOTINX+1
      IOTBUF(IOTINX)=NB(J)
320   CONTINUE
      RETURN
C***  END OF THE RECORD, ADD THE BYTE COUNT AND CHECKSUM
400   J=(IOTINX-2)/2
      IOTCKS=KCFF-IAND(IOTCKS+J,KCFF)
      INX=0
      CALL MPUCNA (J,K16,K2)
      IOTBUF(3)=NB(1)
      IOTBUF(4)=NB(2)
      CALL MPUCNA (IOTCKS,K16,K2)
      IOTINX=IOTINX+1
      IOTBUF(IOTINX)=NB(3)
      IOTINX=IOTINX+1
      IOTBUF(IOTINX)=NB(4)
      CALL PNCHR1 (LUOT,IOTBUF,IOTINX)
C***  RESET 'OT' BUFFER SWITCH, 1=> BUFFER EMPTY
      IOTSW=1
      RETURN
      END
[\].
Y@@@@@SRC
C.MPUSNC (Y)
      SUBROUTINE MPUSNC (JCHR)
C+    NAM: MPUSNC  VER: 1.0  DAT: 12-29-73  CMP: ALL
C     PGM: P#
C
C     SYS: ALL
C
C     ENT: N/A
C
C     RTN: N/A
C
C     FNC:
C
C     GEN:
C
C     REV: N/A
C*
      COMMON ICOMON(237),NB(121),INX
      INX=INX+1
      NB(INX)=JCHR
      RETURN
      END
[\].
Z@@@@@SRC
C.BDATA1 (Z)
C
C  31 JAN 78 (PDH) CHANGE VALUE OF 'NOP' OPCODE TO 01 FROM 02
C
      BLOCK DATA
C     NAM: MPADBK  VER: 1.0  DAT: 10-01-74  CMP: SIGMA-9
C     PGM: LABELED COMMON FOR 'M68SAM'
C
C     SYS: 'M68SAM'
      COMMON /A/ NOPCD(246),IOPBC2(51),IOPBC3(16)
      COMMON /A/ IOPBC4(116),IOPBC5(22)
      DATA NOPCD(1)/10801/,NOPCD(2)/23130/
      DATA NOPCD(3)/23072/,NOPCD(4)/20033/,NOPCD(5)/19744/
      DATA NOPCD(6)/17742/,NOPCD(7)/17440/,NOPCD(8)/19791/
      DATA NOPCD(9)/20000/,NOPCD(10)/20545/,NOPCD(11)/18245/
      DATA NOPCD(12)/20306/,NOPCD(13)/18208/,NOPCD(14)/17745/
      DATA NOPCD(15)/21792/,NOPCD(16)/17987/,NOPCD(17)/16928/
      DATA NOPCD(18)/17987/,NOPCD(19)/17184/,NOPCD(20)/17988/
      DATA NOPCD(21)/16928/,NOPCD(22)/21069/,NOPCD(23)/16928/
      DATA NOPCD(24)/21328/,NOPCD(25)/17184/,NOPCD(26)/20304/
      DATA NOPCD(27)/21536/,NOPCD(28)/10802/,NOPCD(29)/20047/
      DATA NOPCD(30)/20512/,NOPCD(31)/21569/,NOPCD(32)/20512/
      DATA NOPCD(33)/21584/,NOPCD(34)/16672/,NOPCD(35)/18766/
      DATA NOPCD(36)/22560/,NOPCD(37)/17477/,NOPCD(38)/22560/
      DATA NOPCD(39)/17228/,NOPCD(40)/22048/,NOPCD(41)/21317/
      DATA NOPCD(42)/22048/,NOPCD(43)/17228/,NOPCD(44)/17184/
      DATA NOPCD(45)/21317/,NOPCD(46)/17184/,NOPCD(47)/17228/
      DATA NOPCD(48)/18720/,NOPCD(49)/21317/,NOPCD(50)/18720/
      DATA NOPCD(51)/21314/,NOPCD(52)/16672/,NOPCD(53)/17218/
      DATA NOPCD(54)/16672/,NOPCD(55)/21569/,NOPCD(56)/16928/
      DATA NOPCD(57)/21570/,NOPCD(58)/16672/,NOPCD(59)/17473/
      DATA NOPCD(60)/16672/,NOPCD(61)/16706/,NOPCD(62)/16672/
      DATA NOPCD(63)/21587/,NOPCD(64)/22560/,NOPCD(65)/18766/
      DATA NOPCD(66)/21280/,NOPCD(67)/20565/,NOPCD(68)/19521/
      DATA NOPCD(69)/20565/,NOPCD(70)/19522/,NOPCD(71)/17477/
      DATA NOPCD(72)/21280/,NOPCD(73)/21592/,NOPCD(74)/21280/
      DATA NOPCD(75)/20563/,NOPCD(76)/18497/,NOPCD(77)/20563/
      DATA NOPCD(78)/18498/,NOPCD(79)/21076/,NOPCD(80)/21280/
      DATA NOPCD(81)/21076/,NOPCD(82)/18720/,NOPCD(83)/22337/
      DATA NOPCD(84)/18720/,NOPCD(85)/21335/,NOPCD(86)/18720/
      DATA NOPCD(87)/20037/,NOPCD(88)/18241/,NOPCD(89)/17231/
      DATA NOPCD(90)/19777/,NOPCD(91)/19539/,NOPCD(92)/21057/
      DATA NOPCD(93)/21071/,NOPCD(94)/21057/,NOPCD(95)/16723/
      DATA NOPCD(96)/21057/,NOPCD(97)/16723/,NOPCD(98)/19521/
      DATA NOPCD(99)/21071/,NOPCD(100)/19521/,NOPCD(101)/17477/
      DATA NOPCD(102)/17217/,NOPCD(103)/18766/
      DATA NOPCD(104)/17217/,NOPCD(105)/21587/
      DATA NOPCD(106)/21569/,NOPCD(107)/17228/
      DATA NOPCD(108)/21057/,NOPCD(109)/20037/
      DATA NOPCD(110)/18242/,NOPCD(111)/17231/
      DATA NOPCD(112)/19778/,NOPCD(113)/19539/
      DATA NOPCD(114)/21058/,NOPCD(115)/21071/
      DATA NOPCD(116)/21058/,NOPCD(117)/16723/
      DATA NOPCD(118)/21058/,NOPCD(119)/16723/
      DATA NOPCD(120)/19522/,NOPCD(121)/21071/
      DATA NOPCD(122)/19522/,NOPCD(123)/17477/
      DATA NOPCD(124)/17218/,NOPCD(125)/18766/
      DATA NOPCD(126)/17218/,NOPCD(127)/21587/
      DATA NOPCD(128)/21570/,NOPCD(129)/17228/
      DATA NOPCD(130)/21058/,NOPCD(131)/10803/
      DATA NOPCD(132)/16979/,NOPCD(133)/21024/
      DATA NOPCD(134)/16978/,NOPCD(135)/16672/
      DATA NOPCD(136)/16968/,NOPCD(137)/18720/
      DATA NOPCD(138)/16972/,NOPCD(139)/21280/
      DATA NOPCD(140)/16963/,NOPCD(141)/17184/
      DATA NOPCD(142)/16963/,NOPCD(143)/21280/
      DATA NOPCD(144)/16974/,NOPCD(145)/17696/
      DATA NOPCD(146)/16965/,NOPCD(147)/20768/
      DATA NOPCD(148)/16982/,NOPCD(149)/17184/
      DATA NOPCD(150)/16982/,NOPCD(151)/21280/
      DATA NOPCD(152)/16976/,NOPCD(153)/19488/
      DATA NOPCD(154)/16973/,NOPCD(155)/18720/
      DATA NOPCD(156)/16967/,NOPCD(157)/17696/
      DATA NOPCD(158)/16972/,NOPCD(159)/21536/
      DATA NOPCD(160)/16967/,NOPCD(161)/21536/
      DATA NOPCD(162)/16972/,NOPCD(163)/17696/
      DATA NOPCD(164)/10804/,NOPCD(165)/19524/
      DATA NOPCD(166)/21280/,NOPCD(167)/19524/
      DATA NOPCD(168)/22560/,NOPCD(169)/17232/
      DATA NOPCD(170)/22560/,NOPCD(171)/21332/
      DATA NOPCD(172)/21280/,NOPCD(173)/21332/
      DATA NOPCD(174)/22560/,NOPCD(175)/19021/
      DATA NOPCD(176)/20512/,NOPCD(177)/19027/
      DATA NOPCD(178)/21024/,NOPCD(179)/21333/
      DATA NOPCD(180)/16961/,NOPCD(181)/17229/
      DATA NOPCD(182)/20545/,NOPCD(183)/21314/
      DATA NOPCD(184)/17217/,NOPCD(185)/16718/
      DATA NOPCD(186)/17473/,NOPCD(187)/16969/
      DATA NOPCD(188)/21569/,NOPCD(189)/19524/
      DATA NOPCD(190)/16705/,NOPCD(191)/21332/
      DATA NOPCD(192)/16705/,NOPCD(193)/17743/
      DATA NOPCD(194)/21057/,NOPCD(195)/16708/
      DATA NOPCD(196)/17217/,NOPCD(197)/20306/
      DATA NOPCD(198)/16705/,NOPCD(199)/16708/
      DATA NOPCD(200)/17473/,NOPCD(201)/21333/
      DATA NOPCD(202)/16962/,NOPCD(203)/17229/
      DATA NOPCD(204)/20546/,NOPCD(205)/21314/
      DATA NOPCD(206)/17218/,NOPCD(207)/16718/
      DATA NOPCD(208)/17474/,NOPCD(209)/16969/
      DATA NOPCD(210)/21570/,NOPCD(211)/19524/
      DATA NOPCD(212)/16706/,NOPCD(213)/21332/
      DATA NOPCD(214)/16706/,NOPCD(215)/17743/
      DATA NOPCD(216)/21058/,NOPCD(217)/16708/
      DATA NOPCD(218)/17218/,NOPCD(219)/20306/
      DATA NOPCD(220)/16706/,NOPCD(221)/16708/
      DATA NOPCD(222)/17474/,NOPCD(223)/10805/
      DATA NOPCD(224)/20037/,NOPCD(225)/18208/
      DATA NOPCD(226)/17231/,NOPCD(227)/19744/
      DATA NOPCD(228)/19539/,NOPCD(229)/21024/
      DATA NOPCD(230)/21071/,NOPCD(231)/21024/
      DATA NOPCD(232)/16723/,NOPCD(233)/21024/
      DATA NOPCD(234)/16723/,NOPCD(235)/19488/
      DATA NOPCD(236)/21071/,NOPCD(237)/19488/
      DATA NOPCD(238)/17477/,NOPCD(239)/17184/
      DATA NOPCD(240)/18766/,NOPCD(241)/17184/
      DATA NOPCD(242)/21587/,NOPCD(243)/21536/
      DATA NOPCD(244)/17228/,NOPCD(245)/21024/
      DATA NOPCD(246)/10809/,IOPBC2(1)/1/,IOPBC2(2)/6/
      DATA IOPBC2(3)/7/,IOPBC2(4)/8/,IOPBC2(5)/9/,IOPBC2(6)/10/
      DATA IOPBC2(7)/11/,IOPBC2(8)/12/,IOPBC2(9)/13/
      DATA IOPBC2(10)/14/,IOPBC2(11)/15/,IOPBC2(12)/16/
      DATA IOPBC2(13)/17/,IOPBC2(14)/22/,IOPBC2(15)/23/
      DATA IOPBC2(16)/25/,IOPBC2(17)/27/,IOPBC2(18)/48/
      DATA IOPBC2(19)/49/,IOPBC2(20)/50/,IOPBC2(21)/51/
      DATA IOPBC2(22)/52/,IOPBC2(23)/53/,IOPBC2(24)/54/
      DATA IOPBC2(25)/55/,IOPBC2(26)/57/,IOPBC2(27)/59/
      DATA IOPBC2(28)/62/,IOPBC2(29)/63/,IOPBC2(30)/64/
      DATA IOPBC2(31)/67/,IOPBC2(32)/68/,IOPBC2(33)/70/
      DATA IOPBC2(34)/71/,IOPBC2(35)/72/,IOPBC2(36)/73/
      DATA IOPBC2(37)/74/,IOPBC2(38)/76/,IOPBC2(39)/77/
      DATA IOPBC2(40)/79/,IOPBC2(41)/80/,IOPBC2(42)/83/
      DATA IOPBC2(43)/84/,IOPBC2(44)/86/,IOPBC2(45)/87/
      DATA IOPBC2(46)/88/,IOPBC2(47)/89/,IOPBC2(48)/90/
      DATA IOPBC2(49)/92/,IOPBC2(50)/93/,IOPBC2(51)/95/
      DATA IOPBC3(1)/141/,IOPBC3(2)/32/,IOPBC3(3)/34/
      DATA IOPBC3(4)/35/,IOPBC3(5)/36/,IOPBC3(6)/37/
      DATA IOPBC3(7)/38/,IOPBC3(8)/39/,IOPBC3(9)/40/
      DATA IOPBC3(10)/41/,IOPBC3(11)/42/,IOPBC3(12)/43/
      DATA IOPBC3(13)/44/,IOPBC3(14)/45/,IOPBC3(15)/46/
      DATA IOPBC3(16)/47/,IOPBC4(1)/158/,IOPBC4(2)/174/
      DATA IOPBC4(3)/142/,IOPBC4(4)/190/,IOPBC4(5)/222/
      DATA IOPBC4(6)/238/,IOPBC4(7)/206/,IOPBC4(8)/254/
      DATA IOPBC4(9)/156/,IOPBC4(10)/172/,IOPBC4(11)/140/
      DATA IOPBC4(12)/188/,IOPBC4(13)/159/,IOPBC4(14)/175/
      DATA IOPBC4(15)/1/,IOPBC4(16)/191/,IOPBC4(17)/223/
      DATA IOPBC4(18)/239/,IOPBC4(19)/1/,IOPBC4(20)/255/
      DATA IOPBC4(21)/126/,IOPBC4(22)/110/,IOPBC4(23)/1/
      DATA IOPBC4(24)/126/,IOPBC4(25)/189/,IOPBC4(26)/173/
      DATA IOPBC4(27)/1/,IOPBC4(28)/189/,IOPBC4(29)/144/
      DATA IOPBC4(30)/160/,IOPBC4(31)/128/,IOPBC4(32)/176/
      DATA IOPBC4(33)/145/,IOPBC4(34)/161/,IOPBC4(35)/129/
      DATA IOPBC4(36)/177/,IOPBC4(37)/146/,IOPBC4(38)/162/
      DATA IOPBC4(39)/130/,IOPBC4(40)/178/,IOPBC4(41)/148/
      DATA IOPBC4(42)/164/,IOPBC4(43)/132/,IOPBC4(44)/180/
      DATA IOPBC4(45)/149/,IOPBC4(46)/165/,IOPBC4(47)/133/
      DATA IOPBC4(48)/181/,IOPBC4(49)/150/,IOPBC4(50)/166/
      DATA IOPBC4(51)/134/,IOPBC4(52)/182/,IOPBC4(53)/151/
      DATA IOPBC4(54)/167/,IOPBC4(55)/1/,IOPBC4(56)/183/
      DATA IOPBC4(57)/152/,IOPBC4(58)/168/,IOPBC4(59)/136/
      DATA IOPBC4(60)/184/,IOPBC4(61)/153/,IOPBC4(62)/169/
      DATA IOPBC4(63)/137/,IOPBC4(64)/185/,IOPBC4(65)/154/
      DATA IOPBC4(66)/170/,IOPBC4(67)/138/,IOPBC4(68)/186/
      DATA IOPBC4(69)/155/,IOPBC4(70)/171/,IOPBC4(71)/139/
      DATA IOPBC4(72)/187/,IOPBC4(73)/208/,IOPBC4(74)/224/
      DATA IOPBC4(75)/192/,IOPBC4(76)/240/,IOPBC4(77)/209/
      DATA IOPBC4(78)/225/,IOPBC4(79)/193/,IOPBC4(80)/241/
      DATA IOPBC4(81)/210/,IOPBC4(82)/226/,IOPBC4(83)/194/
      DATA IOPBC4(84)/242/,IOPBC4(85)/212/,IOPBC4(86)/228/
      DATA IOPBC4(87)/196/,IOPBC4(88)/244/,IOPBC4(89)/213/
      DATA IOPBC4(90)/229/,IOPBC4(91)/197/,IOPBC4(92)/245/
      DATA IOPBC4(93)/214/,IOPBC4(94)/230/,IOPBC4(95)/198/
      DATA IOPBC4(96)/246/,IOPBC4(97)/215/,IOPBC4(98)/231/
      DATA IOPBC4(99)/1/,IOPBC4(100)/247/,IOPBC4(101)/216/
      DATA IOPBC4(102)/232/,IOPBC4(103)/200/,IOPBC4(104)/248/
      DATA IOPBC4(105)/217/,IOPBC4(106)/233/,IOPBC4(107)/201/
      DATA IOPBC4(108)/249/,IOPBC4(109)/218/,IOPBC4(110)/234/
      DATA IOPBC4(111)/202/,IOPBC4(112)/250/,IOPBC4(113)/219/
      DATA IOPBC4(114)/235/,IOPBC4(115)/203/,IOPBC4(116)/251/
      DATA IOPBC5(1)/96/,IOPBC5(2)/112/,IOPBC5(3)/99/
      DATA IOPBC5(4)/115/,IOPBC5(5)/100/,IOPBC5(6)/116/
      DATA IOPBC5(7)/102/,IOPBC5(8)/118/,IOPBC5(9)/103/
      DATA IOPBC5(10)/119/,IOPBC5(11)/104/,IOPBC5(12)/120/
      DATA IOPBC5(13)/105/,IOPBC5(14)/121/,IOPBC5(15)/106/
      DATA IOPBC5(16)/122/,IOPBC5(17)/108/,IOPBC5(18)/124/
      DATA IOPBC5(19)/109/,IOPBC5(20)/125/,IOPBC5(21)/111/
      DATA IOPBC5(22)/127/
C
C***  'EBCDIC' TO ASCII AND ASCII TO 'EBCDIC' TRNSLATE TABLES
C
C     THESE TABLES DELETED ON PDP-9
C
      END
[\].
