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

946 lines
27 KiB
Fortran
Raw Blame History

C***********************************************************************
C
C XQIO.FOR
C
C
C D I S C L A I M E R N O T I C E
C ------------------- -----------
C
C This document and/or portions of the material and data furnished
C herewith, was developed under sponsorship of the U. S. Government.
C Neither the U.S. nor the U.S.D.O.E., nor the Leland Stanford Junior
C University, nor their employees, nor their respective contractors,
C subcontractors, or their employees, makes any warranty, express or
C implied, or assumes any liability or responsibility for accuracy,
C completeness or usefulness of any information, apparatus, product
C or process disclosed, or represents that its use will not infringe
C privately-owned rights. Mention of any product, its manufacturer,
C or suppliers shall not, nor is it intended to, imply approval, dis-
C approval, or fitness for any particular use. The U. S. and the
C University at all times retain the right to use and disseminate same
C for any purpose whatsoever. Such distribution shall be made by the
C National Energy Software Center at the Argonne National Laboratory
C and only subject to the distributee furnishing satisfactory proof
C that he has a valid license from the Intel Corporation in effect.
C
C-----------------------------------------------------------------------
C
C XQIO -- UDI I/O PACKAGE FOR VAX/VMS UTILIZING THE
C "CORE FILE" CONCEPT.
C
C-----------------------------------------------------------------------
C
C H001 20MAY81 ALEX HUNTER 1. WRITTEN.
C H002 09JUN81 ALEX HUNTER 1. IMPLEMENTED DQ$SPECIAL.
C H003 10JUN81 ALEX HUNTER 1. DQ$EXIT CALLS LIB$STOP.
C H004 08JAN82 ALEX HUNTER 1. TREAT 'LIST:...' AS INTER-
C ACTIVE (NON-CORE FILE) ON
C OUTPUT.
C H005 12JAN82 Alex Hunter 1. Allocate core dynamically.
C H006 31JAN82 Alex Hunter 1. Add indirect command file completion
C codes to DQ$EXIT.
C 2. Handle EOF on :CI:.
C H007 03FEB82 Alex Hunter 1. Change routine names.
C H008 06FEB82 Alex Hunter 1. Use local copies of RMSDEF.FOR and
C IODEF.FOR include files.
C
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION DQATTACH (PATH,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
INTEGER*4 N
INTEGER*4 DESCRIPTOR(2)
DATA DESCRIPTOR /1,0/
CHARACTER*45 XQ___PATH,FULLY_QUALIFIED_NAME
LOGICAL*4 FILE_EXISTS,EOF,XQ___READ,XQ___ENSURE_ALLOCATED
CHARACTER*10 CC
DQATTACH=0
DO CONN=CONN_MIN,CONN_MAX
IF (STATE(CONN).EQ.STATE_UNATTACHED) GO TO 100
ENDDO
STATUS=E$CONTEXT
RETURN
100 FILENAME(CONN)=XQ___PATH(PATH,STATUS)
IF (STATUS.NE.E$OK) RETURN
LENGTH(CONN)=0
MARKER(CONN)=0
IF (FILENAME(CONN)(1:3).EQ.'BB:') THEN
TYPE(CONN)=BYTE_BUCKET
ACCESS_RIGHTS(CONN)=AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ELSE
INQUIRE (FILE=FILENAME(CONN),NAME=FULLY_QUALIFIED_NAME,
# EXIST=FILE_EXISTS,CARRIAGECONTROL=CC,ERR=900)
IF (.NOT.FILE_EXISTS) THEN
STATUS=E$FNEXIST
RETURN
ENDIF
OPEN (UNIT=CONN,FILE=FILENAME(CONN),STATUS='OLD',
# ACCESS='SEQUENTIAL',READONLY,ERR=910)
IF (FILENAME(CONN)(1:3).EQ.'CI:' .OR.
# FULLY_QUALIFIED_NAME(1:3).EQ.'_TT' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$INPUT:' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$COMMAND:') THEN
TYPE(CONN)=INTERACTIVE
ACCESS_RIGHTS(CONN)=AR_READ
SEEK_CAPABILITY(CONN)=0
SPECIAL_MODE(CONN)=LINE_EDITED
ELSE
TYPE(CONN)=NORMAL
ACCESS_RIGHTS(CONN)=AR_DELETE+AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
DO WHILE (.TRUE.)
! Ensure room for max size record + CRLF.
IF (.NOT.XQ___ENSURE_ALLOCATED(CONN,
# LENGTH(CONN)+MAX_INPUT+1))
# THEN
STATUS=E$MEM ! Can't get core.
CLOSE (UNIT=CONN)
RETURN
ENDIF
IF (LENGTH(CONN)/CHUNK_SIZE.EQ.
# (LENGTH(CONN)+MAX_INPUT-1)/CHUNK_SIZE)
# THEN
! Record is guaranteed to fit in current chunk.
DESCRIPTOR(2) =
# CHUNK_ADDRESS(LENGTH(CONN)/CHUNK_SIZE,CONN) +
# MOD(LENGTH(CONN),CHUNK_SIZE)
EOF=XQ___READ(CONN,DESCRIPTOR,N)
ELSE
! Record might cross chunk boundary, so read it
! into a temporary buffer and then copy it to the
! core file.
EOF=XQ___READ(CONN,%DESCR(TEMPORARY_BUFFER),N)
CALL XQ___MOVE_TO_FILE (CONN,TEMPORARY_BUFFER,
# LENGTH(CONN),N)
ENDIF
IF (EOF) GO TO 200
LENGTH(CONN)=LENGTH(CONN)+N
IF (CC.NE.'NONE') THEN
CALL XQ___MOVE_TO_FILE(CONN,%REF(CRLF),LENGTH(CONN),2)
LENGTH(CONN)=LENGTH(CONN)+2
ENDIF
ENDDO
200 CLOSE (UNIT=CONN)
ENDIF
ENDIF
MODIFIED(CONN)=.FALSE.
STATE(CONN)=STATE_ATTACHED
STATUS=E$OK
DQATTACH = CONN
RETURN
900 CONTINUE
910 CONTINUE
STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
LOGICAL*4 FUNCTION XQ___READ (CONN,BUFFER,N)
INCLUDE 'XQCOMMON.FOR/NOLIST'
CHARACTER*1 BUFFER
INTEGER*4 N
READ(CONN,1000,END=200) N,BUFFER(1:N)
1000 FORMAT(Q,A)
XQ___READ=.FALSE.
RETURN
200 XQ___READ=.TRUE.
N=0
RETURN
END
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION DQCREATE (PATH,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
CHARACTER*45 XQ___PATH,FULLY_QUALIFIED_NAME
LOGICAL*4 FILE_EXISTS
DQCREATE = 0
DO CONN=CONN_MIN,CONN_MAX
IF (STATE(CONN).EQ.STATE_UNATTACHED) GO TO 100
ENDDO
STATUS=E$CONTEXT
RETURN
100 FILENAME(CONN)=XQ___PATH(PATH,STATUS)
IF (STATUS.NE.E$OK) RETURN
IF (FILENAME(CONN)(1:5).EQ.'WORK:') THEN
TYPE(CONN)=WORK_FILE
ACCESS_RIGHTS(CONN)=AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ELSEIF (FILENAME(CONN)(1:3).EQ.'BB:') THEN
TYPE(CONN)=BYTE_BUCKET
ACCESS_RIGHTS(CONN)=AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ELSE
INQUIRE (FILE=FILENAME(CONN),NAME=FULLY_QUALIFIED_NAME,
# EXIST=FILE_EXISTS,ERR=900)
IF (FILENAME(CONN)(1:3).EQ.'CO:' .OR.
# FILENAME(CONN)(1:5).EQ.'LIST:' .OR.
# FULLY_QUALIFIED_NAME(1:3).EQ.'_TT' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$OUTPUT:' .OR.
# FULLY_QUALIFIED_NAME.EQ.'SYS$ERROR:') THEN
TYPE(CONN)=INTERACTIVE
ACCESS_RIGHTS(CONN)=AR_WRITE
SEEK_CAPABILITY(CONN)=0
SPECIAL_MODE(CONN)=LINE_EDITED
OPEN (UNIT=CONN,FILE=FILENAME(CONN),STATUS='UNKNOWN',
# ERR=900)
ELSE
TYPE(CONN)=NORMAL
ACCESS_RIGHTS(CONN)=AR_DELETE+AR_READ+AR_WRITE+AR_UPDATE
SEEK_CAPABILITY(CONN)=SC_FORWARD+SC_BACKWARD
ENDIF
ENDIF
LENGTH(CONN)=0
MARKER(CONN)=0
MODIFIED(CONN)=.FALSE.
STATE(CONN)=STATE_ATTACHED
STATUS=E$OK
DQCREATE=CONN
RETURN
900 STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
CHARACTER*45 FUNCTION XQ___PATH (PATH,STATUS)
IMPLICIT INTEGER*2 (A-Z)
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
XQ___PATH=' '
N=PATH(1)
IF (N.LE.0 .OR. N.GT.45) THEN
STATUS=E$SYNTAX
RETURN
ENDIF
DO I=1,N
XQ___PATH(I:I)=CHAR(PATH(I+1))
ENDDO
IF (XQ___PATH(1:1).EQ.':') XQ___PATH=XQ___PATH(2:)
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE DQDELETE (PATH,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE PATH(*)
INTEGER*2 STATUS
CHARACTER*45 XQ___PATH,FILE
FILE=XQ___PATH(PATH,STATUS)
IF (STATUS.NE.E$OK) RETURN
OPEN (UNIT=99,FILE=FILE,STATUS='OLD',ERR=900)
CLOSE (UNIT=99,DISP='DELETE',ERR=950)
STATUS=E$OK
RETURN
900 STATUS=E$FNEXIST
RETURN
950 STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE DQRENAME (OLD,NEW,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INCLUDE 'RMSDEF.FOR/NOLIST'
BYTE OLD(*), NEW(*)
INTEGER*2 STATUS
INTEGER*4 XQ___RENAME,IRMS
CHARACTER*45 XQ___PATH,OLD_FILE,NEW_FILE
INTEGER*4 RMSCODE(10)
DATA RMSCODE
//RMS$_SUC,RMS$_DEV,RMS$_DIR,RMS$_FEX,RMS$_FNF,RMS$_FNM
,,RMS$_IDR,RMS$_PRV,RMS$_SUP,RMS$_SYN
//
INTEGER*2 UDICODE(10)
DATA UDICODE
//E$OK,E$SUPPORT,E$SYNTAX,E$FEXIST,E$FNEXIST,E$SYNTAX
,,E$CROSSFS,E$FACCESS,E$SUPPORT,E$SYNTAX
//
OLD_FILE=XQ___PATH(OLD,STATUS)
IF (STATUS.NE.E$OK) RETURN
NEW_FILE=XQ___PATH(NEW,STATUS)
IF (STATUS.NE.E$OK) RETURN
IRMS=XQ___RENAME(OLD_FILE,NEW_FILE)
DO I=1,10
IF (IRMS.EQ.RMSCODE(I)) THEN
STATUS=UDICODE(I)
RETURN
ENDIF
ENDDO
CALL LIB$SIGNAL(%VAL(IRMS))
STATUS=E$FACCESS ! For lack of anything better.
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_DETACH (CONN,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
INTEGER*4 I,N
INTEGER*4 DESCRIPTOR(2)
DATA DESCRIPTOR /1,0/
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ENDIF
IF (STATE(CONN).EQ.STATE_OPEN) CALL XQ_CLOSE(CONN,STATUS)
STATE(CONN)=STATE_UNATTACHED
IF (TYPE(CONN).EQ.NORMAL) THEN
IF (MODIFIED(CONN)) THEN
OPEN (UNIT=CONN,FILE=FILENAME(CONN),STATUS='NEW',
# FORM='FORMATTED',CARRIAGECONTROL='NONE',
# ORGANIZATION='SEQUENTIAL',RECL=OUTPUT_RECL,
# RECORDTYPE='VARIABLE',ERR=900)
DO I=0,LENGTH(CONN)-1,OUTPUT_RECL
N = MIN(LENGTH(CONN)-I,OUTPUT_RECL) ! Next record size.
IF (I/CHUNK_SIZE.EQ.(I+N-1)/CHUNK_SIZE) THEN
! Next record lies entirely within one chunk,
! so we can write it out directly.
DESCRIPTOR(2) =
# CHUNK_ADDRESS(I/CHUNK_SIZE,CONN) +
# MOD(I,CHUNK_SIZE)
CALL XQ___WRITE(CONN,DESCRIPTOR,N)
ELSE
! Next record crosses a chunk boundary, so first
! copy it to a temporary buffer before writing it out.
CALL XQ___MOVE_FROM_FILE(CONN,I,TEMPORARY_BUFFER,N)
CALL XQ___WRITE(CONN,%DESCR(TEMPORARY_BUFFER),N)
ENDIF
ENDDO
CLOSE (UNIT=CONN)
ENDIF
ELSEIF (TYPE(CONN).EQ.INTERACTIVE) THEN
CLOSE (UNIT=CONN)
ENDIF
STATUS=E$OK
RETURN
900 STATUS=E$FACCESS
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ___WRITE (CONN,BUFFER,N)
INCLUDE 'XQCOMMON.FOR/NOLIST'
CHARACTER*1 BUFFER
INTEGER*4 N
WRITE(CONN,1001) BUFFER(1:N)
1001 FORMAT(A)
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_GET CONNECTION STATUS (CONN,INFO,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
BYTE INFO(7)
INTEGER*4 FILE_PTR
BYTE FP(4)
EQUIVALENCE (FILE_PTR,FP)
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ENDIF
FILE_PTR=MARKER(CONN)
INFO(1)=STATE(CONN).EQ.STATE_OPEN
INFO(2)=ACCESS_RIGHTS(CONN)
INFO(3)=SEEK_CAPABILITY(CONN)
INFO(4)=FP(1)
INFO(5)=FP(2)
INFO(6)=FP(3)
INFO(7)=FP(4)
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_OPEN (CONN,ACCESS,NUMBUF,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
BYTE ACCESS,NUMBUF
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
ELSEIF (STATE(CONN).EQ.STATE_OPEN) THEN
STATUS=E$OPEN
RETURN
ELSEIF (ACCESS.LT.1 .OR. ACCESS.GT.3) THEN
STATUS=E$PARAM
RETURN
ENDIF
ACCESS_MODE(CONN)=ACCESS
IF (ACCESS.EQ.AM_WRITE .OR. ACCESS.EQ.AM_UPDATE) THEN
MODIFIED(CONN)=.TRUE.
ENDIF
MARKER(CONN)=0
STATE(CONN)=STATE_OPEN
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_SEEK (CONN,MODE,HIGH_OFFSET,LOW_OFFSET,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,HIGH_OFFSET,LOW_OFFSET,STATUS
BYTE MODE
INTEGER*4 OFFSET
INTEGER*2 OFF(2)
EQUIVALENCE (OFFSET,OFF)
INTEGER*4 I
LOGICAL*4 XQ___ENSURE_ALLOCATED
BYTE ZEROES(512)
DATA ZEROES /512*0/
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ENDIF
IF (TYPE(CONN).EQ.BYTE_BUCKET) GO TO 999
OFF(1)=LOW_OFFSET
OFF(2)=HIGH_OFFSET
GO TO (100,200,300,400), MODE
STATUS=E$PARAM
RETURN
C
C------ MODE 1: SEEK BACKWARD.
C
100 IF ((SEEK_CAPABILITY(CONN).AND.SC_BACKWARD).EQ.0) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=MAX(MARKER(CONN)-OFFSET,0)
GO TO 999
C
C------ MODE 2: SEEK ABSOLUTE.
C
200 IF (SEEK_CAPABILITY(CONN).NE.SC_FORWARD+SC_BACKWARD) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=OFFSET
GO TO 950
C
C------ MODE 3: SEEK FORWARD.
C
300 IF ((SEEK_CAPABILITY(CONN).AND.SC_FORWARD).EQ.0) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=MARKER(CONN)+OFFSET
GO TO 950
C
C------ MODE 4: SEEK BACKWARD FROM END OF FILE.
C
400 IF ((SEEK_CAPABILITY(CONN).AND.SC_BACKWARD).EQ.0) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
MARKER(CONN)=MAX(LENGTH(CONN)-OFFSET,0)
GO TO 999
C
C------ TEST IF FILE NEEDS TO BE EXTENDED WITH NULLS.
C
950 IF (ACCESS_MODE(CONN).EQ.AM_READ) THEN
MARKER(CONN)=MIN(MARKER(CONN),LENGTH(CONN))
ELSEIF (MARKER(CONN).GT.LENGTH(CONN)) THEN
IF (.NOT.XQ___ENSURE_ALLOCATED(CONN,MARKER(CONN)-1)) THEN
STATUS=E$MEM ! Can't get core.
MARKER(CONN)=LENGTH(CONN)
RETURN
ENDIF
DO I=LENGTH(CONN),MARKER(CONN)-1,512
CALL XQ___MOVE_TO_FILE(CONN,ZEROES,I,
# MIN(MARKER(CONN)-I,512))
ENDDO
LENGTH(CONN)=MARKER(CONN)
ENDIF
999 STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
INTEGER*2 FUNCTION XQ_READ (CONN,BUF,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INCLUDE 'IODEF.FOR/NOLIST'
INTEGER*2 CONN,STATUS
CHARACTER*(*) BUF
INTEGER*4 N,K
INTEGER*4 NO_TERMINATORS(2), IO_FUNCTION_CODE
DATA NO_TERMINATORS/0,0/
INTEGER*2 IOSB(4)
LOGICAL*4 SS,SYS$ASSIGN
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ELSEIF (ACCESS_MODE(CONN).EQ.AM_WRITE) THEN
STATUS=E$OWRITE
RETURN
ENDIF
IF (TYPE(CONN).EQ.INTERACTIVE) THEN
IF (SPECIAL_MODE(CONN).EQ.LINE_EDITED) THEN
READ(CONN,1002,END=999) N,BUF(1:MIN(N,LEN(BUF)-2))
1002 FORMAT(Q,A)
K=MIN(N+2,LEN(BUF))
BUF(K-1:K)=CRLF
ELSE ! --- TRANSPARENT.
IF (.NOT.TT_CHANNEL_ASSIGNED) THEN
SS=SYS$ASSIGN('TT',TT_CHANNEL,,)
IF (.NOT.SS) CALL LIB$SIGNAL(%VAL(SS))
TT_CHANNEL_ASSIGNED=.TRUE.
ENDIF
IO_FUNCTION_CODE=IO$_READVBLK+IO$M_NOECHO+IO$M_NOFILTR
IF (SPECIAL_MODE(CONN).EQ.TRANSPARENT_NOWAIT) THEN
IO_FUNCTION_CODE=IO_FUNCTION_CODE+IO$M_TIMED
ENDIF
CALL SYS$QIOW(,%VAL(TT_CHANNEL),%VAL(IO_FUNCTION_CODE),
# IOSB,,,%REF(BUF),%VAL(LEN(BUF)),%VAL(0),
# %REF(NO_TERMINATORS),,)
K=IOSB(2) ! # BYTES ACTUALLY READ.
ENDIF
ELSEIF (TYPE(CONN).EQ.BYTE_BUCKET) THEN
999 K=0 ! End of file.
ELSE
K=MIN(LEN(BUF),LENGTH(CONN)-MARKER(CONN))
CALL XQ___MOVE_FROM_FILE(CONN,MARKER(CONN),%REF(BUF),K)
MARKER(CONN)=MARKER(CONN)+K
ENDIF
STATUS=E$OK
XQ_READ=K
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_WRITE (CONN,BUF,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
CHARACTER*(*) BUF
INTEGER*4 I
LOGICAL*4 XQ___ENSURE_ALLOCATED
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ELSEIF (ACCESS_MODE(CONN).EQ.AM_READ) THEN
STATUS=E$OREAD
RETURN
ENDIF
IF (TYPE(CONN).EQ.INTERACTIVE) THEN
DO I=1,LEN(BUF),80
WRITE(CONN,1003) BUF(I:MIN(LEN(BUF),I+79))
ENDDO
1003 FORMAT('+',A,$)
ELSEIF (TYPE(CONN).EQ.BYTE_BUCKET) THEN
! NO-OP.
ELSE
IF (.NOT.XQ___ENSURE_ALLOCATED(CONN,MARKER(CONN)+LEN(BUF)-1))
# THEN
STATUS=E$MEM ! Can't get core.
RETURN
ENDIF
CALL XQ___MOVE_TO_FILE(CONN,%REF(BUF),MARKER(CONN),LEN(BUF))
MARKER(CONN)=MARKER(CONN)+LEN(BUF)
LENGTH(CONN)=MAX(LENGTH(CONN),MARKER(CONN))
ENDIF
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_TRUNCATE (CONN,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ELSEIF (ACCESS_MODE(CONN).EQ.AM_READ) THEN
STATUS=E$OREAD
RETURN
ENDIF
LENGTH(CONN)=MARKER(CONN)
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_CLOSE (CONN,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 CONN,STATUS
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (STATE(CONN).NE.STATE_OPEN) THEN
STATUS=E$NOPEN
RETURN
ENDIF
STATE(CONN)=STATE_ATTACHED
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_SPECIAL (TYP,PARAMETER,STATUS)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
BYTE TYP
INTEGER*2 PARAMETER,STATUS
INTEGER*2 CONN
GO TO (100,200,300), TYP
STATUS=E$PARAM
RETURN
100 CONTINUE
200 CONTINUE
300 CONTINUE
CONN=PARAMETER
IF (CONN.LT.CONN_MIN .OR. CONN.GT.CONN_MAX) THEN
STATUS=E$PARAM
RETURN
ELSEIF (STATE(CONN).EQ.STATE_UNATTACHED) THEN
STATUS=E$EXIST
RETURN
ELSEIF (TYPE(CONN).NE.INTERACTIVE) THEN
STATUS=E$SUPPORT
RETURN
ENDIF
SPECIAL_MODE(CONN)=TYP
STATUS=E$OK
RETURN
END
C-----------------------------------------------------------------------
SUBROUTINE XQ_EXIT (COMPLETION_CODE)
INCLUDE 'XQCOMMON.FOR/NOLIST'
INCLUDE 'EXCEPT.FOR/NOLIST'
INTEGER*2 COMPLETION_CODE
INTEGER*2 STATUS
EXTERNAL UDI_OK,UDI_WARNINGS,UDI_ERRORS,UDI_FATAL,UDI_ABORT
EXTERNAL UDI_BADINDSYN,UDI_INDNOTLAS,UDI_BADINDFIL,UDI_INDTOOBIG
DO CONN=CONN_MIN,CONN_MAX
IF (STATE(CONN).NE.STATE_UNATTACHED) THEN
CALL XQ_DETACH(CONN,STATUS)
ENDIF
ENDDO
GO TO (1,2,3,4), COMPLETION_CODE+1
GO TO (101,102,103,104), COMPLETION_CODE-100
CALL LIB$SIGNAL(UDI_ABORT)
1 CALL EXIT
2 CALL LIB$SIGNAL(UDI_WARNINGS)
CALL EXIT
3 CALL LIB$SIGNAL(UDI_ERRORS)
CALL EXIT
4 CALL LIB$SIGNAL(UDI_FATAL)
CALL EXIT
101 CALL LIB$SIGNAL(UDI_BADINDSYN)
CALL EXIT
102 CALL LIB$SIGNAL(UDI_INDNOTLAS)
CALL EXIT
103 CALL LIB$SIGNAL(UDI_BADINDFIL)
CALL EXIT
104 CALL LIB$SIGNAL(UDI_INDTOOBIG)
CALL EXIT
END
LOGICAL*4 FUNCTION XQ___ENSURE_ALLOCATED (CONN, BYTE_INDEX)
C-----------------------------------------------------------------------
C
C This function is called to ensure that enough core is allocated
C to contain bytes 0..BYTE_INDEX for connection CONN.
C
C Returns .TRUE. if enough core is allocated.
C Returns .FALSE. if core not available, or chunk table size
C would be exceeded.
C
C Assumes CONN is a valid connection number.
C Assumes BYTE_INDEX > 0.
C Assumes chunks are consecutively allocated from chunk 0 up.
C
C-----------------------------------------------------------------------
INCLUDE 'XQCOMMON.FOR/NOLIST'
INTEGER*2 CONN ! Connection token.
INTEGER*4 BYTE_INDEX ! Highest byte index necessary to be
! allocated.
INTEGER*4 CHUNK
LOGICAL*4 LIB$GET_VM
IF (BYTE_INDEX.GE.MAX_CORE_FILE_SIZE) THEN
XQ___ENSURE_ALLOCATED=.FALSE. ! Chunk table size exceeded.
RETURN
ENDIF
IF (CHUNK_ADDRESS(BYTE_INDEX/CHUNK_SIZE,CONN).NE.0) THEN
XQ___ENSURE_ALLOCATED=.TRUE. ! Already allocated.
RETURN
ENDIF
! Allocate any missing chunks, up through the highest one needed.
DO CHUNK=0,BYTE_INDEX/CHUNK_SIZE
IF (CHUNK_ADDRESS(CHUNK,CONN).EQ.0) THEN
IF (.NOT.LIB$GET_VM(CHUNK_SIZE,CHUNK_ADDRESS(CHUNK,CONN)))
# THEN
XQ___ENSURE_ALLOCATED=.FALSE. ! Can't get core.
CHUNK_ADDRESS(CHUNK,CONN)=0
RETURN
ENDIF
ENDIF
ENDDO
XQ___ENSURE_ALLOCATED=.TRUE. ! Successfully allocated core.
RETURN
END
SUBROUTINE XQ___MOVE_TO_FILE (CONN, BUFFER, BYTE_INDEX, N_BYTES)
C-----------------------------------------------------------------------
C
C This subroutine is called to copy a bufferful of bytes into
C a core file.
C
C Assumes N_BYTES < 64K.
C Assumes the necessary core in the core file has already been
C allocated.
C
C-----------------------------------------------------------------------
INCLUDE 'XQCOMMON.FOR/NOLIST'
INTEGER*2 CONN ! Connection token.
BYTE BUFFER(0:*) ! Buffer to move from.
INTEGER*4 BYTE_INDEX ! Index in core file to start copying to.
INTEGER*4 N_BYTES ! Number of bytes to move (< 64K).
INTEGER*4 I,N,K,START_INDEX
I = 0 ! Index into buffer.
N = N_BYTES ! Number of bytes left to move.
START_INDEX = BYTE_INDEX ! Core file index to start next move.
DO WHILE (N.GT.0)
K = MIN(N, CHUNK_SIZE-MOD(START_INDEX,CHUNK_SIZE))
! Max bytes we can transfer without crossing chunk boundary.
CALL PLM$MOVE (%VAL(K),
# BUFFER(I),
# %VAL(CHUNK_ADDRESS(START_INDEX/CHUNK_SIZE,CONN)+
# MOD(START_INDEX,CHUNK_SIZE)))
I = I+K
START_INDEX = START_INDEX+K
N = N-K
ENDDO
RETURN
END
SUBROUTINE XQ___MOVE_FROM_FILE (CONN, BYTE_INDEX, BUFFER, N_BYTES)
C-----------------------------------------------------------------------
C
C This subroutine is called to copy a bufferful of bytes out of a
C core file
C
C Assumes N_BYTES < 64K.
C Assumes the necessary core in the core file is already allocated.
C
C-----------------------------------------------------------------------
INCLUDE 'XQCOMMON.FOR/NOLIST'
INTEGER*2 CONN ! Connection token.
INTEGER*4 BYTE_INDEX ! Index in core file to start copying
! from.
BYTE BUFFER(0:*) ! Buffer to move to.
INTEGER*4 N_BYTES ! Number of bytes to move (< 64K).
INTEGER*4 I,N,K,START_INDEX
I = 0 ! Index into buffer.
N = N_BYTES ! Number of bytes left to move.
START_INDEX = BYTE_INDEX ! Core file index to start next move.
DO WHILE (N.GT.0)
K = MIN(N,CHUNK_SIZE-MOD(START_INDEX,CHUNK_SIZE))
! Max bytes we can transfer without crossing chunk boundary.
CALL PLM$MOVE (%VAL(K),
# %VAL(CHUNK_ADDRESS(START_INDEX/CHUNK_SIZE,CONN)+
# MOD(START_INDEX,CHUNK_SIZE)),
# BUFFER(I))
I = I+K
START_INDEX = START_INDEX+K
N = N-K
ENDDO
RETURN
END
Reference in New Issue View Git Blame Copy Permalink