/SYS REGION=400K
/FILE SYSPUNCH NAME($Y65:BBCMOS.OBJ) NEW(REPL)
/INCLUDE FORTG
/OPT DECK
/JOB NOGO
C
C     BBC MOS emulation package. All communication from the 6502
C     emulator is carried out by calling the OPSYS routine.
C
      SUBROUTINE OPSYS
      IMPLICIT INTEGER (A-Z,$)
      INTEGER FLAGS /ZF0000000/
      LOGICAL UIO,EQUAL
      LOGICAL*1 WRLINE(80),BUFFER(80),ERROR(80),ASCII(256),EBCDIC(256)
      LOGICAL*1 CLS /Z70/
      COMMON /TABLES/ ASCII,EBCDIC
      COMMON /REGS/ A,X,Y,P,PC,SP
      COMMON /WRCH/ WRLINE,WRCPTR
      DATA TIME /0/
C
C     System calls :  1 - OSBYTE    2 - OSWORD   3 - OSWRCH   4 - OSRDCH
C                     5 - OSFILE    6 - OSARGS   7 - OSBGET   8 - OSBPUT
C                     9 - OSGBPB   10 - OSFIND  11 - OSFSC   12 - Others
C
      TEMP=PC-768
      GOTO (1,2,3,4,5,6,7,8,9,10,11,12),TEMP
C
C     Perform selected OSBYTE calls
C
 1    IF (A.EQ.0) GOTO 90000
      GO TO 90001
90000 CONTINUE
        IF (X.EQ.0) GOTO 90003
      GO TO 90004
90003 CONTINUE
          CALL BRK(247,'OS 6.3|')
      GO TO 90005
90004 CONTINUE
          X=6
90005 CONTINUE
      GO TO 90002
90001 CONTINUE
      IF      (A.EQ.124.OR.A.EQ.126) GOTO 90006
      GO TO 90007
90006 CONTINUE
        CALL WRMEM(255,0)
      GO TO 90002
90007 CONTINUE
      IF      (A.EQ.125) GOTO 90008
      GO TO 90009
90008 CONTINUE
        CALL WRMEM(255,128)
      GO TO 90002
90009 CONTINUE
      IF      (A.EQ.129) GOTO 90010
      GO TO 90011
90010 CONTINUE
        IF (Y.NE.255) CALL DELAY((X+256*Y)/100)
        X=0
        Y=0
        P=LAND(P,254+FLAGS)
      GO TO 90002
90011 CONTINUE
      IF      (A.EQ.130) GOTO 90012
      GO TO 90013
90012 CONTINUE
        X=0
        Y=0
      GO TO 90002
90013 CONTINUE
      IF      (A.EQ.131) GOTO 90014
      GO TO 90015
90014 CONTINUE
        X=0
        Y=8
      GO TO 90002
90015 CONTINUE
      IF      (A.EQ.132.OR.A.EQ.133) GOTO 90016
      GO TO 90017
90016 CONTINUE
        X=0
        Y=247
      GO TO 90002
90017 CONTINUE
      IF      (A.EQ.218) GOTO 90018
      GO TO 90019
90018 CONTINUE
      GO TO 90002
90019 CONTINUE
      IF      (A.EQ.11.OR.A.EQ.12.OR.A.EQ.15) GOTO 90020
      GO TO 90021
90020 CONTINUE
      GO TO 90002
90021 CONTINUE
        WRITE (6,1000) A
 1000   FORMAT(' *Unsupported OSBYTE call ',Z2)
        RETURN
90002 CONTINUE
      RETURN
C
C     Read a line from the keyboard (OSWORD 0) Also do 1 and 2.
C     Note bug in BBC manuals - Y should NOT include CR.
C
 2    IF (A.GT.2) GOTO 90022
      GO TO 90023
90022 CONTINUE
        WRITE (6,2000) A
 2000   FORMAT(' *Unsupported OSWORD call ',Z2)
        RETURN
90024 CONTINUE
90023 CONTINUE
      TEMP=A+1
      GOTO (2100,2200,2300), TEMP
 2100 CALL WRBUF
      CALL TEXTLC
      READ (9,2101) BUFFER
      CALL TEXTUC
 2101 FORMAT(80A1)
      CBLK=X+256*Y
      ADDR=RDMEM(CBLK)+RDMEM(LAND(CBLK+1,65535))*256
      MAXLEN=RDMEM(LAND(CBLK+2,65535))
      Y=LOCATE(BUFFER,-80,' ',-1)
      IF (Y.GT.MAXLEN) Y=MAXLEN
      DO 2102 I=1,Y
        CALL WRMEM(LAND(ADDR+I-1,65535),BYTE(ASCII(BYTE(BUFFER(I))+1)))
 2102 CONTINUE
      CALL WRMEM(LAND(ADDR+Y,65535),13)
      P=LAND(P,254+FLAGS)
      RETURN
 2200 ADDR=X+Y*256
      CALL TSTIME(2,TEMP)
      TEMP=TEMP*100-TIME
      DO 2201 I=1,4
        CALL WRMEM(ADDR+I-1,TEMP/256**(I-1))
 2201 CONTINUE
      CALL WRMEM(ADDR+4,0)
      RETURN
 2300 ADDR=X+Y*256
      CALL TSTIME(2,TIME)
      TIME=TIME*100
      DO 2301 I=1,4
        TIME=TIME+RDMEM(ADDR+I-1)*256**(I-1)
 2301 CONTINUE
      RETURN
C
C     OSWRCH - Write a character to the screen
C
 3    IF (A.GE.32.OR.A.EQ.10) GOTO 90028
      GO TO 90029
90028 CONTINUE
        WRCPTR=WRCPTR+1
C       WRLINE(WRCPTR:WRCPTR)=EBCDIC(A)
        CALL LMOVE(EBCDIC(A+1),WRLINE(WRCPTR),1)
      GO TO 90030
90029 CONTINUE
      IF      (A.EQ.12) GOTO 90031
      GO TO 90032
90031 CONTINUE
        CALL WRBUF
        WRITE (6,3000) CLS
 3000   FORMAT(A1)
90030 CONTINUE
90032 CONTINUE
      IF (A.EQ.13.OR.WRCPTR.EQ.80) CALL WRBUF
      RETURN
C
C     OSRDCH (Very iffy!)
C
 4    CONTINUE
      CALL MFSETU(9)
      CALL MFIO(RC,'*.',0,80,BUFFER)
      P=LAND(P,254+FLAGS)
      IF (RC.NE.0) P=LOR(P,1)
      A=BYTE(ASCII(BYTE(BUFFER)+1))
      RETURN
C
C     OSFILE routines
C
 5    ADDR=X+Y*256
      FNAMEA=RDMEM(ADDR)+RDMEM(ADDR+1)*256
      DO 5000 I=1,64
C       BUFFER(I:I)=EBCDIC(RDMEM(FNAMEA+I-1)+1)
        CALL LMOVE(EBCDIC(RDMEM(FNAMEA+I-1)+1),BUFFER(I),1)
        IF (EQUAL(BUFFER(I),' ',1)) GOTO 5001
 5000 CONTINUE
 5001 CONTINUE
      MLOAD=0
      MEXEC=0
      MSTRT=0
      MEND=0
      DO 5002 I=1,4
        MLOAD=MLOAD+RDMEM(ADDR+1+I)*256**(I-1)
        MEXEC=MEXEC+RDMEM(ADDR+5+I)*256**(I-1)
        MSTRT=MSTRT+RDMEM(ADDR+9+I)*256**(I-1)
        MEND=MEND+RDMEM(ADDR+13+I)*256**(I-1)
 5002 CONTINUE
      CALL FLINFO(BUFFER,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
      IF (A.EQ.0) GOTO 90035
      GO TO 90036
90035 CONTINUE
        IF (RC.NE.0) ATRIBS=4
        IF (LAND(ATRIBS,2).EQ.2) GOTO 90038
      GO TO 90039
90038 CONTINUE
          CALL BRK(193,'Write not allowed|')
          A=1
          RETURN
90040 CONTINUE
90039 CONTINUE
        LENGTH=MEND-MSTRT
        CALL SAVFIL(BUFFER,MSTRT,LENGTH)
        CALL WRCAT(BUFFER,MLOAD,MEXEC,LENGTH,ATRIBS)
      GO TO 90037
90036 CONTINUE
        IF (RC.EQ.30.AND.A.EQ.255) CALL BRK(214,'File not found|')
        IF (RC.NE.0) GOTO 90041
      GO TO 90042
90041 CONTINUE
          A=0
          RETURN
90043 CONTINUE
90042 CONTINUE
        IF (A.GE.5) GOTO 90044
      GO TO 90045
90044 CONTINUE
          DO 5003 I=1,4
            CALL WRMEM(ADDR+1+I,LOAD/256**(I-1))
            CALL WRMEM(ADDR+5+I,EXEC/256**(I-1))
            CALL WRMEM(ADDR+9+I,LENGTH/256**(I-1))
            CALL WRMEM(ADDR+13+I,ATRIBS/256**(I-1))
 5003     CONTINUE
90046 CONTINUE
90045 CONTINUE
        IF (A.EQ.1) GOTO 90048
      GO TO 90049
90048 CONTINUE
          CALL WRCAT(BUFFER,MLOAD,MEXEC,LENGTH,MEND)
      GO TO 90050
90049 CONTINUE
      IF        (A.EQ.2) GOTO 90051
      GO TO 90052
90051 CONTINUE
          CALL WRCAT(BUFFER,MLOAD,EXEC,LENGTH,ATRIBS)
      GO TO 90050
90052 CONTINUE
      IF        (A.EQ.3) GOTO 90053
      GO TO 90054
90053 CONTINUE
          CALL WRCAT(BUFFER,LOAD,MEXEC,LENGTH,ATRIBS)
      GO TO 90050
90054 CONTINUE
      IF        (A.EQ.4) GOTO 90055
      GO TO 90056
90055 CONTINUE
          CALL WRCAT(BUFFER,LOAD,EXEC,LENGTH,MEND)
      GO TO 90050
90056 CONTINUE
      IF        (A.EQ.6) GOTO 90057
      GO TO 90058
90057 CONTINUE
          IF (LAND(ATRIBS,8).EQ.8) GOTO 90059
      GO TO 90060
90059 CONTINUE
            CALL BRK(195,'Delete not allowed|')
            A=1
            RETURN
90061 CONTINUE
90060 CONTINUE
          CALL PURGE(-1,BUFFER,RC)
          IF (RC.NE.0) GOTO 90062
      GO TO 90063
90062 CONTINUE
            CALL CORE(ERROR,80)
            WRITE (1,5004) RC,BUFFER
 5004   FORMAT('MUSIC error ',I3, ' encountered deleting file ',A36,'|')
            CALL BRK(128,ERROR)
90064 CONTINUE
90063 CONTINUE
      GO TO 90050
90058 CONTINUE
      IF        (A.EQ.255) GOTO 90065
      GO TO 90066
90065 CONTINUE
          IF (LAND(ATRIBS,1).EQ.1) GOTO 90067
      GO TO 90068
90067 CONTINUE
            CALL BRK(195,'Read not allowed|')
            A=1
            RETURN
90069 CONTINUE
90068 CONTINUE
          IF (LAND(MEXEC,255).EQ.0) LOAD=MLOAD
          CALL LODFIL(BUFFER,LOAD,LENGTH,LRECL,UIO,RC)
90050 CONTINUE
90066 CONTINUE
90037 CONTINUE
      A=1
      RETURN
C
C     OSARGS
C
 6    CONTINUE
      IF (Y.EQ.0) GOTO 90070
      GO TO 90071
90070 CONTINUE
        IF (A.EQ.0) GOTO 90073
      GO TO 90074
90073 CONTINUE
          A=4
      GO TO 90075
90074 CONTINUE
      IF        (A.EQ.1) GOTO 90076
      GO TO 90077
90076 CONTINUE
          CALL WRMEM(LAND(X+0,255),RUNADR)
          CALL WRMEM(LAND(X+1,255),RUNADR/256)
          CALL WRMEM(LAND(X+2,255),255)
          CALL WRMEM(LAND(X+3,255),255)
90075 CONTINUE
90077 CONTINUE
90072 CONTINUE
90071 CONTINUE
      RETURN
C
C     OSBGET
C
 7    CALL FILES(1,A,Y,0)
      RETURN
C
C     OSBPUT
C
 8    CALL FILES(2,A,Y,0)
      RETURN
C
C     OSGBPB
C
 9    CONTINUE
      RETURN
C
C     OSFIND
C
 10   IF (A.NE.0) GOTO 90078
      GO TO 90079
90078 CONTINUE
        ADDR=X+Y*256
        CALL FILL(BUFFER,80,' ')
        DO 10000 I=1,64
C         BUFFER(I+1:I+1)=EBCDIC(RDMEM(ADDR+I))
          CALL LMOVE(EBCDIC(RDMEM(ADDR+I-1)+1),BUFFER(I),1)
          IF (EQUAL(BUFFER(I),' ',1)) GOTO 10001
10000   CONTINUE
10001   CONTINUE
90080 CONTINUE
90079 CONTINUE
      IF (LAND(A,63).EQ.0) CALL FILES(A,A,Y,BUFFER)
      RETURN
C
C     OSFSC routines
C
 11   IF (A.EQ.2.OR.A.EQ.4) GOTO 90082
      GO TO 90083
90082 CONTINUE
C       *RUN
        ADDR=X+Y*256
        DO 1100  I=1,80
          TEMP=RDMEM(ADDR+I-1)
          IF (TEMP.NE.32.AND.TEMP.NE.13) GOTO 90087
C           BUFFER(I+1:I+1)=' '
            CALL LMOVE(' ',BUFFER(I),1)
            RUNADR=ADDR+I-1
            GOTO 1101
90087 CONTINUE
C         BUFFER(I+1:I+1)=EBCDIC(TEMP)
          CALL LMOVE(EBCDIC(TEMP+1),BUFFER(I),1)
 1100   CONTINUE
 1101   CONTINUE
        DO 1102 I=1,80
          IF (RDMEM(RUNADR+I-1).NE.32) GOTO 1103
          RUNADR=RUNADR+1
 1102   CONTINUE
 1103   CONTINUE
        CALL FLINFO(BUFFER,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
        IF (RC.EQ.30) CALL BRK(214,'File not found|')
        IF (RC.NE.0) RETURN
        IF (LAND(ATRIBS,4).EQ.4) GOTO 90090
      GO TO 90091
90090 CONTINUE
          CALL BRK(195,'Execute not allowed|')
          RETURN
90092 CONTINUE
90091 CONTINUE
        CALL LODFIL(BUFFER(LEN+1),LOAD,LENGTH,LRECL,UIO,RC)
        IF (RC.NE.0) RETURN
        A=1
        CALL EXECUT(EXEC)
      GO TO 90084
90083 CONTINUE
      IF      (A.EQ.3) GOTO 90093
      GO TO 90094
90093 CONTINUE
        CALL BRK(254,'Bad command|')
      GO TO 90084
90094 CONTINUE
      IF      (A.EQ.5) GOTO 90095
      GO TO 90096
90095 CONTINUE
        CALL NXTCMD('DIR * X',7,228)
90084 CONTINUE
90096 CONTINUE
      RETURN
C
C     Perform miscellaneous tasks, mainly from OSCLI
C
 12   IF (A.EQ.0) GOTO 90097
      GO TO 90098
90097 CONTINUE
C       CALL NXTCMD('DEFINE PFn =WHATEVER',?,228)
      GO TO 90099
90098 CONTINUE
      IF      (A.EQ.1) GOTO 90100
      GO TO 90101
90100 CONTINUE
C       Execute MUSIC command (*MUSIC)
        CALL FILL(BUFFER,80,' ')
        ADDR=X+256*Y
        DO 1201 I=1,80
          TEMP=RDMEM(ADDR+I-1)
          IF (TEMP.EQ.13) GOTO 1202
C         BUFFER(I+1:I+1)=EBCDIC(TEMP)
          CALL LMOVE(EBCDIC(TEMP+1),BUFFER(I),1)
 1201   CONTINUE
 1202   CONTINUE
        CALL NXTCMD(BUFFER,80,228)
90099 CONTINUE
90101 CONTINUE
      RETURN
      END
C
C     Output the current screen buffer and start a new one
C
      SUBROUTINE WRBUF
      IMPLICIT INTEGER($)
      IMPLICIT INTEGER (A-Z)
      LOGICAL EQUAL
      LOGICAL*1 WRLINE(80)
      COMMON /WRCH/ WRLINE,WRCPTR
      IF (WRCPTR.EQ.0) RETURN
      WRITE (6,1) (WRLINE(I),I=1,WRCPTR)
    1 FORMAT(1X,80A1)
      WRCPTR=0
      RETURN
      END
C
C     Open a file and extract the BBC file attributes from the tag
C     Copy it into memory in the required position.
C
      SUBROUTINE FLINFO(FILNAM,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
      IMPLICIT INTEGER($)
      IMPLICIT INTEGER (A-Z)
      INTEGER*2 INFO(10)
      LOGICAL*1 FILNAM(64),TAG(64)
      LOGICAL UIO,EQUAL
      COMMON /MFTAG/ TAG
      COMMON /MFINFO/ INFO
      CALL MFACT(RC,'EXTRACT.',-1,FILNAM)
      IF (RC.NE.0) GOTO 90000
      GO TO 90001
90000 CONTINUE
        IF (RC.EQ.12) GOTO 90003
      GO TO 90004
90003 CONTINUE
          CALL BRK(204,'Bad filename|')
      GO TO 90005
90004 CONTINUE
      IF        (RC.NE.30) GOTO 90006
      GO TO 90007
90006 CONTINUE
          CALL BRK(128,'MUSIC error opening file|')
90005 CONTINUE
90007 CONTINUE
        RETURN
90002 CONTINUE
90001 CONTINUE
      CALL TOUC(TAG,9)
      IF (.NOT.EQUAL(TAG,'BBC FILE ',9)) GOTO 90008
      GO TO 90009
90008 CONTINUE
        CALL BRK(128,'File is not a BBC file|')
        RC=-1
        RETURN
90010 CONTINUE
90009 CONTINUE
      CALL X2I(TAG(10),8,LOAD,RC1,BAD)
      CALL X2I(TAG(19),8,EXEC,RC2,BAD)
      CALL X2I(TAG(28),8,LENGTH,RC3,BAD)
      IF (.NOT.EQUAL(TAG(37),'R',1).AND..NOT.EQUAL(TAG(37),' ',1)) RC3=1
      IF (.NOT.EQUAL(TAG(38),'W',1).AND..NOT.EQUAL(TAG(38),' ',1)) RC3=1
      IF (.NOT.EQUAL(TAG(39),'X',1).AND..NOT.EQUAL(TAG(39),' ',1)) RC3=1
      IF (.NOT.EQUAL(TAG(40),'D',1).AND..NOT.EQUAL(TAG(40),' ',1)) RC3=1
      IF (RC1+RC2+RC3.NE.0) GOTO 90011
      GO TO 90012
90011 CONTINUE
        CALL BRK(128,'File attributes are incorrect|')
        RC=-1
        RETURN
90013 CONTINUE
90012 CONTINUE
      ATRIBS=0
      IF (EQUAL(TAG(37),' ',1)) ATRIBS=ATRIBS+1
      IF (EQUAL(TAG(38),' ',1)) ATRIBS=ATRIBS+2
      IF (EQUAL(TAG(39),' ',1)) ATRIBS=ATRIBS+4
      IF (EQUAL(TAG(40),' ',1)) ATRIBS=ATRIBS+8
      LRECL=INFO(7)
      RECFM=BYTE(INFO(8))
      IF (RECFM.EQ.0) GOTO 90014
      GO TO 90015
90014 CONTINUE
        UIO=.TRUE.
        LRECL=512
      GO TO 90016
90015 CONTINUE
        UIO=.FALSE.
90016 CONTINUE
      RETURN
      END
C
C     Load a file from disk into memory
C
      SUBROUTINE LODFIL(FILNAM,LOAD,LENGTH,LRECL,UIO,RC)
      IMPLICIT INTEGER($)
      IMPLICIT INTEGER (A-Z)
      LOGICAL*1 FILNAM(64),RECORD(32760),ERROR(80)
      LOGICAL UIO
      COMMON /OSFILE/ RECORD
      COMMON /MFPHYS/ RECLEN,RBA
      LOAD=LAND(LOAD,65535)
      CALL MFACT(RC,'OPEN OKOLD RDOK.',-1,FILNAM)
      IF (RC.NE.0) GOTO 3
      BYTES=0
    1   IF (UIO) GOTO 90000
      GO TO 90001
90000 CONTINUE
          CALL MFIO(RC,'UIO RD.',0,LRECL,RECORD)
      GO TO 90002
90001 CONTINUE
          CALL MFIO(RC,'IO RD.',0,LRECL,RECORD)
90002 CONTINUE
        IF (RC.NE.0) GOTO 3
        DO 2 I=1,RECLEN
          IF (BYTES.GE.LENGTH) GOTO 5
          CALL WRMEM(LOAD+I-1,BYTE(RECORD(I)))
          BYTES=BYTES+1
    2   CONTINUE
        LOAD=LOAD+RECLEN
      GOTO 1
    3 IF (RC.GT.1) GOTO 90004
      GO TO 90005
90004 CONTINUE
        CALL CORE(ERROR,80)
        WRITE (1,4) RC,FILNAM
    4   FORMAT('MUSIC error ',I3, ' encountered reading file ',A36,'|')
        CALL BRK(128,ERROR)
90006 CONTINUE
90005 CONTINUE
      IF (RC.EQ.1) RC=0
    5 CALL MFACT(RET,'CLOSE.',-1,FILNAM)
      RETURN
      END
C
C     Save a file onto disk from memory
C
      SUBROUTINE SAVFIL(FILNAM,START,LENGTH)
      IMPLICIT INTEGER($)
      IMPLICIT INTEGER (A-Z)
      LOGICAL*1 FILNAM(64),RECORD(32760),ERROR(80)
      INTEGER PRIV /Z0000C0C0/, F /Z0100/, FC /Z0200/
      INTEGER    PRIM, SEC, MAXK, ACCESS
      INTEGER*2  LRECL, RECFM
      COMMON /MFINFO/ PRIM,SEC,MAXK,LRECL,RECFM,ACCESS
      COMMON /OSFILE/ RECORD
      CALL PURGE(-1,FILNAM,RC)
      IF (RC.NE.0.AND.RC.NE.30) GOTO 90000
      GO TO 90001
90000 CONTINUE
        CALL CORE(ERROR,80)
        WRITE (1,4) RC,FILNAM
        CALL BRK(128,ERROR)
        RETURN
90002 CONTINUE
90001 CONTINUE
      PRIM=LENGTH/1024 + 2
      SEC=0
      MAXK=-1
      LRECL=256
      RECFM=F
      ACCESS=PRIV
      CALL MFACT(RC,'OPEN OKNEW WROK.',-1,FILNAM)
      IF (RC.NE.0) GOTO 3
      PAGES=(LENGTH+255)/256
    1 IF (PAGES.EQ.0) GOTO 5
        DO 2 I=1,256
          CALL LBMOVE(RDMEM(START+I-1),4,RECORD(I),1,1)
    2   CONTINUE
        CALL MFIO(RC,'IO WR.',0,256,RECORD)
        IF (RC.NE.0) GOTO 3
        PAGES=PAGES-1
        START=START+256
      GOTO 1
    3 CALL CORE(ERROR,80)
      WRITE (1,4) RC,FILNAM
    4 FORMAT('MUSIC error ',I3, ' encountered writing file ',A36,'|')
      CALL BRK(128,ERROR)
    5 CALL MFACT(RET,'CLOSE RLSE.',-1,FILNAM)
      RETURN
      END
C
C     Write the catalogue entry (tag) for a BBC file
C
      SUBROUTINE WRCAT(FILNAM,LOAD,EXEC,LENGTH,ATRIBS)
      IMPLICIT INTEGER($)
      IMPLICIT INTEGER (A-Z)
      LOGICAL*1 FILNAM(64),TAG(64)
      COMMON /MFTAG/ TAG
      CALL MFACT(RC,'OPEN OKOLD WROK.',-1,FILNAM)
      CALL LMOVE('BBC file ',TAG,9)
      CALL I2X(LOAD,TAG(10))
      CALL I2X(EXEC,TAG(19))
      CALL I2X(LENGTH,TAG(28))
      IF (LAND(ATRIBS,1).EQ.0) CALL LMOVE('R',TAG(37),1)
      IF (LAND(ATRIBS,2).EQ.0) CALL LMOVE('W',TAG(38),1)
      IF (LAND(ATRIBS,4).EQ.0) CALL LMOVE('X',TAG(39),1)
      IF (LAND(ATRIBS,8).EQ.0) CALL LMOVE('D',TAG(40),1)
      CALL MFACT(RC,'CLOSE RLSE CTAG.',-1,FILNAM)
      RETURN
      END
C
C     Error encountered in OS. Write a BRK plus message to the end of
C     the stack and execute it - paged rom style.
C
      SUBROUTINE BRK(ERR,ERRSTR)
      IMPLICIT INTEGER (A-Z,$)
      LOGICAL EQUAL
      LOGICAL*1 ERRSTR(80),ASCII(256),EBCDIC(256)
      COMMON /TABLES/ ASCII,EBCDIC
      CALL WRMEM(256,0)
      CALL WRMEM(257,ERR)
      I=1
    1   CALL WRMEM(257+I,BYTE(ASCII(BYTE(ERRSTR(I))+1)))
        I=I+1
        IF (.NOT.EQUAL(ERRSTR(I),'|',1)) GOTO 1
      CALL WRMEM(257+I,0)
      CALL EXECUT(256)
      RETURN
      END
C
C     Fix the return address on the stack to start execution elsewhere
C
      SUBROUTINE EXECUT(ADDR)
      IMPLICIT INTEGER($)
      IMPLICIT INTEGER (A-Z)
      COMMON /REGS/ A,X,Y,P,PC,SP
      CALL WRMEM(SP+256,LAND(ADDR-1,65280)/256)
      SP=LAND(SP-1,255)
      CALL WRMEM(SP+256,LAND(ADDR-1,255))
      SP=LAND(SP-1,255)
      RETURN
      END
C
C     Carry out OSFIND, OSBGET, OSBPUT, OSARGS, OSGBPB
C
      SUBROUTINE FILES(CODE,A,Y,FILNAM)
      IMPLICIT INTEGER($)
C
C     OPNFLS : Word 1  bit 0 - Read allowed on this file
C                      bit 1 - Write allowed on this file
C                      bit 4 - EOF warning has been given
C                      bit 5 - Length has exceeded cat length
C                      bit 6 - Sector in memory must be written to disk
C                      bit 7 - Sector in memory contains PTR
C
C                      bits 8 - ?  : Sector number in memory
C
C              Word 2  Internal MUSIC unit number
C
C              Word 3  Files MUSIC record length
C
C              Word 4
C
      IMPLICIT INTEGER (A-Z)
      LOGICAL EQUAL
      LOGICAL*1 OPNFNM(10,64),BUFFER(10,256)
      INTEGER OPNFLS(10,4) /40*0/,PTR(10),EXT(10)
      LOGICAL*1 FILNAM(64),ERROR(80)
      INTEGER PRIV /Z0000C0C0/, F /Z0100/, FC /Z0200/, FLAGS /ZF0000000/
      INTEGER*2 LRECL,RECFM
      INTEGER    PRIM, SEC, MAXK, ACCESS
      COMMON /MFINFO/ PRIM,SEC,MAXK,LRECL,RECFM,ACCESS
      IF (CODE.LT.5.AND.(CODE.NE.0.OR.Y.NE.0)) GOTO 90000
      GO TO 90001
90000 CONTINUE
        IF (OPNFLS(Y,1).EQ.0) GOTO 90003
      GO TO 90004
90003 CONTINUE
          CALL BRK(222,'Bad file channel|')
          RETURN
90005 CONTINUE
90004 CONTINUE
90002 CONTINUE
90001 CONTINUE
C
C     OSBGET
C
      IF (CODE.EQ.1) GOTO 90006
      GO TO 90007
90006 CONTINUE
        IF (LAND(OPNFLS(Y,1),1).EQ.0) GOTO 90009
      GO TO 90010
90009 CONTINUE
          CALL BRK(195,'Read not allowed|')
          RETURN
90011 CONTINUE
90010 CONTINUE
        IF (PTR(Y).GE.EXT(Y)) GOTO 90012
      GO TO 90013
90012 CONTINUE
          IF (LAND(OPNFLS(Y,1),16).NE.0) GOTO 90015
      GO TO 90016
90015 CONTINUE
            CALL BRK(223,'EOF|')
            RETURN
C     GO TO 90017
90016 CONTINUE
            OPNFLS(Y,1)=LOR(OPNFLS(Y,1),16)
            P=LOR(P,1)
            A=254
            RETURN
90017 CONTINUE
90014 CONTINUE
90013 CONTINUE
        IF (LAND(OPNFLS(Y,1),128).EQ.0) GOTO 90018
      GO TO 90019
90018 CONTINUE
          CALL MFSETU(OPNFLS(Y,2))
          IF (LAND(OPNFLS(Y,1),64).NE.0) GOTO 90021
      GO TO 90022
90021 CONTINUE
C           WRITE OUT SECTOR
90023 CONTINUE
90022 CONTINUE
C         READ IN SECTOR
C         65280 SHOULD BE BIGGER FOR FILES > 64K
          OPNFLS(Y,1)=LAND(LOR(OPNFLS(Y,1),128),191)+LAND(PTR(Y),65280)
90020 CONTINUE
90019 CONTINUE
        A=BYTE(BUFFER(Y,LAND(PTR(Y),255)+1))
        PTR(Y)=PTR(Y)+1
C       65407 SHOULD BE BIGGER FOR FILES > 64K
        IF (LAND(PTR(Y),255).EQ.0) OPNFLS(Y,1)=LAND(OPNFLS(Y,1),65407)
        P=LAND(P,254+FLAGS)
C
C     OSBPUT
C
      GO TO 90008
90007 CONTINUE
      IF      (CODE.EQ.2) GOTO 90024
      GO TO 90025
90024 CONTINUE
        IF (LAND(OPNFLS(Y,1),2).EQ.0) GOTO 90026
      GO TO 90027
90026 CONTINUE
          CALL BRK(193,'Write not allowed|')
          RETURN
90028 CONTINUE
90027 CONTINUE
        IF (LAND(OPNFLS(Y,1),128).EQ.0) GOTO 90029
      GO TO 90030
90029 CONTINUE
          IF (LAND(OPNFLS(Y,1),64).NE.0) GOTO 90032
      GO TO 90033
90032 CONTINUE
            CALL MFSETU(OPNFLS(Y,2))
C           WRITE OUT SECTOR
90034 CONTINUE
90033 CONTINUE
          IF (LAND(EXT(Y),255).EQ.0.AND.PTR(Y).EQ.EXT(Y)) GOTO 90035
      GO TO 90036
90035 CONTINUE
C             Flag sector_after_ext as current one in buffer
      GO TO 90037
90036 CONTINUE
            CALL MFSETU(OPNFLS(Y,2))
C           READ IN SECTOR
90037 CONTINUE
C         65280 SHOULD BE BIGGER FOR FILES > 64K
          OPNFLS(Y,1)=LAND(LOR(OPNFLS(Y,1),128),191)+LAND(PTR(Y),65280)
90031 CONTINUE
90030 CONTINUE
        CALL LMOVE(A,BUFFER(Y,LAND(PTR(Y),255)+1),1)
        OPNFLS(Y,1)=LOR(OPNFLS(Y,1),64)
        PTR(Y)=PTR(Y)+1
C       65407 SHOULD BE BIGGER FOR FILES > 64K
        IF (LAND(PTR(Y),255).EQ.0) OPNFLS(Y,1)=LAND(OPNFLS(Y,1),65407)
        IF (PTR(Y).GT.EXT(Y)) GOTO 90038
      GO TO 90039
90038 CONTINUE
          EXT(Y)=PTR(Y)
          OPNFLS(Y,1)=LOR(OPNFLS(Y,1),32)
90040 CONTINUE
90039 CONTINUE
      GO TO 90008
90025 CONTINUE
      IF      (CODE.EQ.64.OR.CODE.EQ.128.OR.CODE.EQ.192) GOTO 90041
      GO TO 90042
90041 CONTINUE
C
C     See if we have an available channel. Also check if file is open
C     already. Can be open more than once, but all access must be read.
C     Note that the same filename can be specified in different ways -
C     this will subvert this check.
C
        A=0
        I=10
3       CONTINUE
C       DO 1 I=10,1,-1
          IF (OPNFLS(I,1).EQ.0) GOTO 90044
      GO TO 90045
90044 CONTINUE
            A=I
      GO TO 90046
90045 CONTINUE
C           IF (OPNFNM(I).EQ.FILNAM.AND.
            IF (EQUAL(OPNFNM(I,1),FILNAM,64).AND.
     +         (LAND(OPNFLS(I,1),2).EQ.2.OR.CODE.GT.64)) GOTO 90047
      GO TO 90048
90047 CONTINUE
              CALL BRK(194,'File open|')
              RETURN
90049 CONTINUE
90048 CONTINUE
90046 CONTINUE
  1     CONTINUE
        I=I-1
        IF (I.GT.0) GOTO 3
        IF (A.EQ.0) GOTO 90050
      GO TO 90051
90050 CONTINUE
          CALL BRK(192,'Too many files open|')
          RETURN
90052 CONTINUE
90051 CONTINUE
C
C       Look for file in catalogue
C
        CALL FLINFO(FILNAM,LOAD,EXEC,LENGTH,ATRIBS,LRECL,UIO,RC)
C
C       Check access to the file and set up pointers etc
C
        OPNFLS(A,1)=0
        IF (LAND(CODE,64).EQ.64) GOTO 90053
      GO TO 90054
90053 CONTINUE
          IF (RC.EQ.0) GOTO 90056
      GO TO 90057
90056 CONTINUE
            IF (LAND(ATRIBS,1).EQ.1) GOTO 90059
      GO TO 90060
90059 CONTINUE
              CALL BRK(195,'Read not allowed|')
              RETURN
90061 CONTINUE
90060 CONTINUE
      GO TO 90058
90057 CONTINUE
            IF (RC.NE.30) GOTO 90062
      GO TO 90063
90062 CONTINUE
              CALL CORE(ERROR,80)
              WRITE (1,2) RC,FILNAM
              CALL BRK(128,ERROR)
90064 CONTINUE
90063 CONTINUE
            A=0
            RETURN
90058 CONTINUE
          EXT(A)=LENGTH
          OPNFLS(A,1)=1
90055 CONTINUE
90054 CONTINUE
        IF (LAND(CODE,128).EQ.128) GOTO 90065
      GO TO 90066
90065 CONTINUE
          IF (RC.NE.0) ATRIBS=4
          IF (LAND(ATRIBS,2).EQ.2) GOTO 90068
      GO TO 90069
90068 CONTINUE
            CALL BRK(193,'Write not allowed|')
            RETURN
C     GO TO 90070
90069 CONTINUE
      IF          (RC.NE.30) GOTO 90071
      GO TO 90072
90071 CONTINUE
            CALL CORE(ERROR,80)
            WRITE (1,2) RC,FILNAM
            CALL BRK(128,ERROR)
            RETURN
90070 CONTINUE
90072 CONTINUE
          OPNFLS(A,1)=OPNFLS(A,1)+2
90067 CONTINUE
90066 CONTINUE
        IF (CODE.EQ.128) GOTO 90073
      GO TO 90074
90073 CONTINUE
          CALL PURGE(-1,FILNAM,RC)
          IF (RC.NE.0.AND.RC.NE.30) GOTO 90076
      GO TO 90077
90076 CONTINUE
            CALL CORE(ERROR,80)
            WRITE (1,2) RC,FILNAM
            CALL BRK(128,ERROR)
            RETURN
90078 CONTINUE
90077 CONTINUE
          PRIM=16
          SEC=0
          MAXK=-1
          LRECL=256
          RECFM=F
          ACCESS=PRIV
          EXT(A)=0
          OPNFLS(A,1)=32+3
90075 CONTINUE
90074 CONTINUE
C       CALL MFACT(RC,'OPEN OKOLD OKNEW RDOK WROK.',-1,FILNAM)
        IF (RC.NE.0) GOTO 90079
      GO TO 90080
90079 CONTINUE
         CALL CORE(ERROR,80)
         WRITE (1,2) RC,FILNAM
    2    FORMAT('MUSIC error ',I3, ' encountered opening file ',A36,'|')
         CALL BRK(128,ERROR)
         RETURN
90081 CONTINUE
90080 CONTINUE
        CALL MFGETU(OPNFLS(A,2))
        OPNFLS(A,3)=LRECL
C       OPNFNM(A)=FILNAM
        CALL LMOVE(FILNAM,OPNFNM(A,1),64)
        PTR(A)=0
C
C     Check if file is already open and that all opens are read
C     Put length in EXT (and PTR if required)
C
      GO TO 90008
90042 CONTINUE
      IF      (CODE.EQ.0) GOTO 90082
      GO TO 90083
90082 CONTINUE
        IF (Y.EQ.0) GOTO 90084
      GO TO 90085
90084 CONTINUE
          DO 8 I=1,10
            CALL OSCLOS(OPNFLS(I,1),OPNFNM(I,1))
  8       CONTINUE
      GO TO 90086
90085 CONTINUE
C
C         Note Channel is verified if A=0 and Y^=0
C
          CALL OSCLOS(OPNFLS(Y,1),OPNFNM(Y,1))
90086 CONTINUE
90008 CONTINUE
90083 CONTINUE
      RETURN
      END
C
C     OSFIND Close
C
      SUBROUTINE OSCLOS(OPNFLS,FILNAM)
      IMPLICIT INTEGER($)
      LOGICAL*1 FILNAM(64)
      INTEGER OPNFLS
C     IF (LAND(OPNFLS,64).EQ.64) WRITE OUT SECTOR
C     IF (LAND(OPNFLS,32).EQ.32) UPDATE CAT ENTRY
      CALL MFACT(RC,'CLOSE RLSE.',-1,FILNAM)
      OPNFLS=0
      RETURN
      END
C
C     Translate tables
C
      BLOCK DATA
      IMPLICIT INTEGER(A-Z,$)
      LOGICAL*1 EBCDIC(256)/ 33*' ','!','"','#','$','%','&','''','(',
     $ ')','*','+',',','-','.','/','0','1','2','3','4','5','6','7','8',
     $ '9',':',';','<','=','>','?','@','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','[','\',']','^','_','`','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','{','|','}','~',129*'%' /
      LOGICAL*1 ASCII(256) /
     $ Z00,Z01,Z02,Z03,Z1A,Z09,Z1A,Z7F,Z1A,Z1A,Z1A,Z0B,Z0C,Z0D,Z0E,Z0F,
     $ Z10,Z11,Z12,Z13,Z1A,Z1A,Z08,Z1A,Z18,Z19,Z1A,Z1A,Z1C,Z1D,Z1E,Z1F,
     $ Z1A,Z1A,Z1C,Z1A,Z1A,Z0A,Z17,Z1B,Z1A,Z1A,Z1A,Z1A,Z1A,Z05,Z06,Z07,
     $ Z1A,Z1A,Z16,Z1A,Z1A,Z1E,Z1A,Z04,Z1A,Z1A,Z1A,Z1A,Z14,Z15,Z1A,Z1A,
     $ Z20,ZA6,ZE1,Z80,ZEB,Z90,Z9F,ZE2,ZAB,Z8B,Z5C,Z2E,Z3C,Z28,Z2B,Z7C,
     $ Z26,ZA9,ZAA,Z9C,ZDB,ZA5,Z99,ZE3,ZA8,Z9E,Z21,Z24,Z2A,Z29,Z3B,Z5E,
     $ Z2D,Z2F,ZDF,ZDC,Z9A,ZDD,ZDE,Z98,Z9D,ZAC,ZBA,Z2C,Z25,Z5F,Z3E,Z3F,
     $ ZD7,Z88,Z94,ZB0,ZB1,ZB2,ZFC,ZD6,ZFB,Z60,Z3A,Z23,Z40,Z27,Z3D,Z22,
     $ Z00,Z61,Z62,Z63,Z64,Z65,Z66,Z67,Z68,Z69,Z96,ZA4,ZF3,ZAF,ZAE,ZC5,
     $ Z8C,Z6A,Z6B,Z6C,Z6D,Z6E,Z6F,Z70,Z71,Z72,Z97,Z87,ZCE,Z93,ZF1,ZFE,
     $ ZC8,Z7E,Z73,Z74,Z75,Z76,Z77,Z78,Z79,Z7A,ZEF,ZC0,ZDA,Z5B,ZF2,ZF9,
     $ ZB5,ZB6,ZFD,ZB7,ZB8,ZB9,ZE6,ZBB,ZBC,ZBD,Z8D,ZD9,ZBF,Z5D,ZD8,ZC4,
     $ Z7B,Z41,Z42,Z43,Z44,Z45,Z46,Z47,Z48,Z49,ZCB,ZCA,ZBE,ZE8,ZEC,ZED,
     $ Z7D,Z4A,Z4B,Z4C,Z4D,Z4E,Z4F,Z50,Z51,Z52,ZA1,ZAD,ZF5,ZF4,ZA3,Z8F,
     $ Z5C,ZE7,Z53,Z54,Z55,Z56,Z57,Z58,Z59,Z5A,ZA0,Z85,Z8E,ZE9,ZE4,ZD1,
     $ Z30,Z31,Z32,Z33,Z34,Z35,Z36,Z37,Z38,Z39,ZB3,ZF7,ZF0,ZFA,ZA7,ZFF/
      COMMON /TABLES/ ASCII,EBCDIC
      END