Trailing-Edge
-
PDP-10 Archives
-
LCG_Integration_Tools_Clearinghouse_T20_v7_30Apr86
-
tools/compil/compil.for
There are 4 other files named compil.for in the archive. Click here to see a list.
C This is the COMPIL program, the program that does the functions of the
C DEC-10 COMPIL program, providing the user with the concise command
C language interface to the compilers and linker.
C Edit History: Version 1(11)
C 1 5-Apr-1983 Initial version
C 2 12-May-1983 When deleting the temp file, include a /NOCONFIRM
C switch in case the user has DELETE defined as
C DELETE/CONFIRM
C 3 19-May-1983 Add the capability to process MESSAGE files
C 4 29-Jun-1983 Define the SVC symbol as global in case COMPIL is run
C from a command procedure
C 5 21-Jul-1983 Correct some problems with edit 3
C 6 21-Jul-1983 Pass correct file spec to link when recompiling is
C not done, so path to file is passed on
C 7 21-Jul-1983 Allow 'TLB', 'MLB' and 'OLB' as valid library file types
C 8 22-Jul-1983 Add capability of having values for qualifiers; also add
C the /LINK and /EXECUTE qualifiers
C 9 20-Oct-1983 If an /EXECUTE qualifier is specified on an execute
C command, the right filename was not being given to
C the RUN command
C 10 25-Jul-1984 Don't output the /CROSS_REFERENCE qualifier to Bliss;
C it doesn't understand it.
C 11 6-Aug-1984 Break up long commands to Link into multiple lines
IMPLICIT NONE
INCLUDE '($LIBCLIDEF)'
INTEGER*4 GLOBAL_FLAGS !Store the global flags here
INTEGER*4 MAX_FILES
PARAMETER (MAX_FILES=64) !Define the maximum number of files
CHARACTER*127 FILE_SPEC(MAX_FILES) !Store the entire filespecs here
CHARACTER*9 FILE_NAME(MAX_FILES) !Store just the file name here
CHARACTER*9 EXNAME !Name of file to execute
CHARACTER*4 EXTENSION !Extension of the file being processed
INTEGER*4 LOCAL_FLAGS(MAX_FILES) !Local flags go here
INTEGER*4 FILE_POINTER !Pointer to the current file being processed
INTEGER*4 NUMBER_FILES !Total number of files found
INTEGER*4 FILE_TYPE !Store type of compiler needed here
INTEGER*4 RET_STATUS !Store status of subroutine calls here
LOGICAL*1 STAT !Status of field scanner goes here
LOGICAL*1 RECOMP !Flag that the file needs to be compiled
LOGICAL*1 TEST_SWITCH
LOGICAL*1 GET_FIELD
LOGICAL*1 GET_VALUE
LOGICAL*1 VALUE_REQUIRED(13) !True if value required on qualifier
CHARACTER*128 QUAL_VALUE(13) !Value of qualifier specified
LOGICAL*1 NEW_COMMAND !True if need to save command string
INTEGER*4 SWITCH
INTEGER*4 I, J, LIB$EXTZV, SCAN_FILE
INTEGER*4 CMD_LENGTH
CHARACTER*256 CMD_LINE
INTEGER*4 LIB$GET_FOREIGN, LIB$LOOKUP_KEY, LIB$SET_SYMBOL
INTEGER*4 LIB$GET_SYMBOL, STR$TRIM
EXTERNAL CMD_TABLE, SWITCH_TABLE
C Define the error message codes
EXTERNAL CML_NOPRVCMD,CML_CNFQUAL,CML_INVQUAL,CML_INVSNTX
EXTERNAL CML_MISFILSPC,CML_FNF,CML_INVCMD,CML_MISQUAL
EXTERNAL CML_FILTBLOVF,CML_INTERR,CML_BADFILTYP
EXTERNAL CML_NOVALU,CML_VALREQ
INTEGER*4 COMP_FLAG, LIST_FLAG, CROSS_FLAG, DEB_FLAG
INTEGER*4 NOCOMP_FLAG, NOLIST_FLAG, NOCROSS_FLAG, NODEB_FLAG
INTEGER*4 RECOMP_FLAG, CONCAT_FLAG, LIBR_FLAG, LINK_FLAG
INTEGER*4 EXE_FLAG
PARAMETER (COMP_FLAG=32,LIST_FLAG=33,CROSS_FLAG=34)
PARAMETER (DEB_FLAG=35,NOCOMP_FLAG=36,NOLIST_FLAG=37)
PARAMETER (NOCROSS_FLAG=38,NODEB_FLAG=39,RECOMP_FLAG=40)
PARAMETER (CONCAT_FLAG=41,LIBR_FLAG=42,LINK_FLAG=43)
PARAMETER (EXE_FLAG=44)
INTEGER BUFF_SIZE !Size of the input command string
PARAMETER (BUFF_SIZE = 255)
CHARACTER*4 EXT_TABLE(10) !Table of known file types
DATA EXT_TABLE/'.FOR','.MAR','.BAS','.BLI','.PAS','.PLI','.MSG',
1 '.TLB','.MLB','.OLB'/
CHARACTER*7 COMMAND_TABLE(10), CMD
DATA COMMAND_TABLE/'Fortran','Macro','Basic','Bliss','Pascal',
1 'PLI','Message','TLB','MLB','OLB'/
CHARACTER*255 FIELD
CHARACTER*1 TERMINATOR
CHARACTER*(BUFF_SIZE) BUFFER
INTEGER*2 OFFSET, SIZE, COMMAND
DATA VALUE_REQUIRED/.FALSE., !Compile
1 .FALSE., !List
2 .FALSE., !Cross
3 .FALSE., !Debug
4 .FALSE., !Nocompile
5 .FALSE., !Nolist
6 .FALSE., !Nocross
7 .FALSE., !Nodebug
8 .FALSE., !Recomp-flag
9 .FALSE., !Concat-flag
1 .FALSE., !Library
2 .TRUE., !Link
3 .TRUE./ !Execute
COMMON /BUFF/ OFFSET, BUFFER !Store the command line here
FILE_POINTER = 1 !Initialize the file spec pointer
FILE_SPEC(FILE_POINTER) = ' ' !Preset first file spec to spaces
NEW_COMMAND = .TRUE. !Assume this is a new command string
C Get the input command line
OFFSET = 1 !Init the pointer to the buffer
RET_STATUS = LIB$GET_FOREIGN(BUFFER)
IF (.NOT. RET_STATUS) GOTO 10
C Decode the command
STAT = GET_FIELD(FIELD, SIZE, TERMINATOR)
IF (FIELD .EQ. ' ') THEN
10 RET_STATUS = LIB$GET_SYMBOL('SVC',BUFFER,,)
IF (.NOT. RET_STATUS) CALL LIB$SIGNAL(CML_NOPRVCMD)
NEW_COMMAND = .FALSE.
OFFSET = 1
STAT = GET_FIELD(FIELD,SIZE,TERMINATOR)
ENDIF
RET_STATUS = LIB$LOOKUP_KEY(FIELD(1:SIZE), CMD_TABLE, COMMAND)
IF (.NOT. RET_STATUS) CALL LIB$SIGNAL(CML_INVCMD,%VAL(1),
1 FIELD(1:SIZE)) !Invalid command
IF (.NOT. STAT) THEN !If no files specified, get from the old symbol
C Come here if only the keyword is specified in the command string. COMMAND
C has been decoded to tell us what to do. See if the symbol SVC has been
C defined
RET_STATUS = LIB$GET_SYMBOL('SVC',BUFFER,,)
IF (.NOT. RET_STATUS) CALL LIB$SIGNAL(CML_NOPRVCMD)
NEW_COMMAND = .FALSE. !Don't save the command
OFFSET = 1 !Start the buffer over again
STAT = GET_FIELD(FIELD,SIZE,TERMINATOR) !Discard the old command name
ENDIF
IF (TERMINATOR .NE. '/') GOTO 150 !Check for global switch
100 IF (.NOT. STAT) GOTO 999 !Check for out of buffer
STAT = GET_FIELD(FIELD, SIZE, TERMINATOR) !Get switch name
IF (SIZE .EQ. 0) CALL LIB$SIGNAL(CML_MISQUAL)!No qualifier found
RET_STATUS = LIB$LOOKUP_KEY(FIELD(1:SIZE),SWITCH_TABLE,SWITCH)
IF (.NOT. RET_STATUS) CALL LIB$SIGNAL(CML_INVQUAL,%VAL(1),
1 FIELD(1:SIZE))!Switch not found
CALL SET_SWITCH(SWITCH, GLOBAL_FLAGS)
IF (TERMINATOR .NE. '=') THEN !Does this qualifier have a value?
IF (VALUE_REQUIRED(SWITCH-31)) !No - is a value required?
1 CALL LIB$SIGNAL(CML_VALREQ,%VAL(1),FIELD(1:SIZE)) !Yes - error
ELSE
IF (.NOT. VALUE_REQUIRED(SWITCH-31)) !Yes - is a value illegal?
1 CALL LIB$SIGNAL(CML_NOVALU,%VAL(1),FIELD(1:SIZE)) !Yes - error
STAT = GET_VALUE(QUAL_VALUE(SWITCH-31),SIZE,TERMINATOR)!Get the value
IF (SIZE .EQ. 0) CALL LIB$SIGNAL(CML_VALREQ,%VAL(1),FIELD(1:SIZE))
ENDIF
IF (TERMINATOR .EQ. '/') GOTO 100 !Scan more global switches
LOCAL_FLAGS(FILE_POINTER) = 0
C Check for conflicting global flags
120 IF (TEST_SWITCH(NOCOMP_FLAG,GLOBAL_FLAGS) .AND.
1 TEST_SWITCH(COMP_FLAG,GLOBAL_FLAGS))
2 CALL LIB$SIGNAL(CML_CNFQUAL)
150 IF (.NOT. STAT) GOTO 250
IF (TERMINATOR .EQ. ',') GOTO 250
IF (TERMINATOR .EQ. ' ') GOTO 300
IF (TERMINATOR .EQ. '+') GOTO 200
IF (TERMINATOR .NE. '/') CALL LIB$SIGNAL(CML_INVSNTX) !Invalid syntax
STAT = GET_FIELD(FIELD, SIZE, TERMINATOR)
IF (SIZE .EQ. 0) CALL LIB$SIGNAL(CML_MISQUAL) !Error - no switch found
RET_STATUS = LIB$LOOKUP_KEY(FIELD(1:SIZE),SWITCH_TABLE,SWITCH)
IF (.NOT. RET_STATUS) CALL LIB$SIGNAL(CML_INVQUAL,%VAL(1),
1 FIELD(1:SIZE))
CALL SET_SWITCH(SWITCH,LOCAL_FLAGS(FILE_POINTER))
IF (TERMINATOR .NE. '=') THEN !Does this qualifier have a value?
IF (VALUE_REQUIRED(SWITCH-31)) !No - is a value required?
1 CALL LIB$SIGNAL(CML_VALREQ,%VAL(1),FIELD(1:SIZE)) !Yes - error
ELSE
IF (.NOT. VALUE_REQUIRED(SWITCH-31)) !Yes - is a value illegal?
1 CALL LIB$SIGNAL(CML_NOVALU,%VAL(1),FIELD(1:SIZE)) !Yes - error
STAT = GET_VALUE(QUAL_VALUE(SWITCH-31),SIZE,TERMINATOR)!Get the value
IF (SIZE .EQ. 0) CALL LIB$SIGNAL(CML_VALREQ,%VAL(1),FIELD(1:SIZE))
ENDIF
GOTO 150 !Go process the next part
200 CALL SET_SWITCH(CONCAT_FLAG,LOCAL_FLAGS(FILE_POINTER))!Set concat flag
250 IF (FILE_SPEC(FILE_POINTER) .EQ. ' ')
1 CALL LIB$SIGNAL(CML_MISFILSPC)
IF (LIB$EXTZV(0,5,LOCAL_FLAGS(FILE_POINTER)) .EQ. 0) THEN
IF (LIB$EXTZV(0,5,GLOBAL_FLAGS) .EQ. 0) THEN
FILE_TYPE = 0
DO I=1,10
IF (EXTENSION .EQ. EXT_TABLE(I)) FILE_TYPE = I
ENDDO
ELSE
FILE_TYPE = LIB$EXTZV(0,5,GLOBAL_FLAGS)
ENDIF
IF (FILE_TYPE .EQ. 0) FILE_TYPE = 1 !Default to Fortran
CALL SET_SWITCH(FILE_TYPE,LOCAL_FLAGS(FILE_POINTER))
ENDIF
C Check for conflicting local flags
IF (TEST_SWITCH(NOCOMP_FLAG,LOCAL_FLAGS(FILE_POINTER)) .AND.
1 TEST_SWITCH(COMP_FLAG,LOCAL_FLAGS(FILE_POINTER)))
2 CALL LIB$SIGNAL(CML_CNFQUAL)
C Set or clear the recomp flag depending on the local and global comp flags
IF (TEST_SWITCH(COMP_FLAG,LOCAL_FLAGS(FILE_POINTER)) .OR.
1 (.NOT. (TEST_SWITCH(COMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
2 .OR. TEST_SWITCH(NOCOMP_FLAG,LOCAL_FLAGS(FILE_POINTER)))
3 .AND. TEST_SWITCH(COMP_FLAG,GLOBAL_FLAGS))) THEN
CALL SET_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
ELSE IF (TEST_SWITCH(NOCOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
1 .OR. (.NOT. (TEST_SWITCH(NOCOMP_FLAG,LOCAL_FLAGS(
2 FILE_POINTER)) .OR. TEST_SWITCH(COMP_FLAG,LOCAL_FLAGS(
3 FILE_POINTER))) .AND. TEST_SWITCH(NOCOMP_FLAG,GLOBAL_FLAGS)))
4 THEN
CALL CLEAR_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
ENDIF
C Don't allow recompile if this is a library file
IF (TEST_SWITCH(LIBR_FLAG,LOCAL_FLAGS(FILE_POINTER))) THEN
CALL CLEAR_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
ELSE
C Don't allow library extensions without the library switch
IF (FILE_TYPE .EQ. 8 .OR. FILE_TYPE .EQ. 9)
1 CALL LIB$SIGNAL(CML_BADFILTYP,%VAL(1),EXTENSION)
ENDIF
IF (.NOT. STAT) GOTO 999
FILE_POINTER = FILE_POINTER + 1 !Step to the next slot
IF (FILE_POINTER .GT. MAX_FILES) CALL LIB$SIGNAL(CML_FILTBLOVF)
FILE_SPEC(FILE_POINTER) = ' '
LOCAL_FLAGS(FILE_POINTER) = 0
300 IF (.NOT. STAT) GOTO 999
STAT = GET_FIELD(FIELD, SIZE, TERMINATOR)
IF (SIZE .EQ. 0) GOTO 150
FILE_SPEC(FILE_POINTER) = FIELD
RET_STATUS = SCAN_FILE(FIELD,EXTENSION,FILE_NAME(FILE_POINTER),
1 RECOMP) !Check the file
IF (.NOT. RET_STATUS)THEN ! If file was not found, issue error message
RET_STATUS = STR$TRIM(FIELD,FILE_SPEC(FILE_POINTER),I)
CALL LIB$SIGNAL(CML_FNF,%VAL(1),FIELD(1:I))
ENDIF
IF (RECOMP) CALL SET_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
GOTO 150
999 NUMBER_FILES = FILE_POINTER !Save the number of files found
FILE_POINTER = 1 !Reset the file pointer
C Now step through the list of files and set all concatenated files
C to use the same processor and show the same name on output, namely
C the name of the last file in the concatenated list
1000 IF (TEST_SWITCH(CONCAT_FLAG,LOCAL_FLAGS(FILE_POINTER))) THEN
I = FILE_POINTER + 1
DO WHILE (I .LE. NUMBER_FILES .AND. TEST_SWITCH(
1 CONCAT_FLAG,LOCAL_FLAGS(I)))
I = I + 1
ENDDO
IF (I .GT. NUMBER_FILES) CALL LIB$SIGNAL(CML_INVSNTX) !No nonconcatenated files found
CALL LIB$INSV(0,0,5,LOCAL_FLAGS(FILE_POINTER))
CALL SET_SWITCH(LIB$EXTZV(0,5,LOCAL_FLAGS(I)),
1 LOCAL_FLAGS(FILE_POINTER))
FILE_NAME(FILE_POINTER) = FILE_NAME(I)
CALL CLEAR_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
IF (TEST_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(I)))
1 CALL SET_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))
ENDIF
FILE_POINTER = FILE_POINTER + 1
IF (FILE_POINTER .LE. NUMBER_FILES) GOTO 1000
C Now transfer the local /LINK and /EXECUTE qualifiers to global qualifiers
DO I=1,NUMBER_FILES
IF (TEST_SWITCH(LINK_FLAG,LOCAL_FLAGS(I))) THEN
IF (TEST_SWITCH(LINK_FLAG,GLOBAL_FLAGS))
1 CALL LIB$SIGNAL(CML_CNFQUAL)
CALL SET_SWITCH(LINK_FLAG,GLOBAL_FLAGS)
ENDIF
IF (TEST_SWITCH(EXE_FLAG,LOCAL_FLAGS(I))) THEN
IF (TEST_SWITCH(EXE_FLAG,GLOBAL_FLAGS))
1 CALL LIB$SIGNAL(CML_CNFQUAL)
CALL SET_SWITCH(EXE_FLAG,GLOBAL_FLAGS)
ENDIF
END DO
C Now generate the command file
C OPEN(UNIT=1,NAME='SYS$OUTPUT:',STATUS='NEW',
C 1 CARRIAGECONTROL='LIST')
OPEN(UNIT=1,NAME='COMPTMP.COM',STATUS='NEW',
1 CARRIAGECONTROL='LIST')
WRITE(1,1090)
1090 FORMAT('$ DELETE/NOLOG/NOCONFIRM COMPTMP.COM.')
FILE_POINTER = 1 !Start at the beginning
C First compile all necessary modules
1100 IF (.NOT. TEST_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER)))
1 GOTO 1999 !Should this be recompiled? No
CMD = COMMAND_TABLE(LIB$EXTZV(0,5,LOCAL_FLAGS(
1 FILE_POINTER)))
I = INDEX(CMD,' ')
IF (I .EQ. 0) I = 8
CMD_LINE = '$ '//CMD !Put the command in the command line
CMD_LENGTH = I + 2 !Set the length of the command line
C Output /LIST if needed
IF (TEST_SWITCH(LIST_FLAG,LOCAL_FLAGS(FILE_POINTER)) .OR.
1 (.NOT. TEST_SWITCH(NOLIST_FLAG,LOCAL_FLAGS(FILE_POINTER))
1 .AND. TEST_SWITCH(LIST_FLAG,GLOBAL_FLAGS))) THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+6) = '/LIST'
CMD_LENGTH = CMD_LENGTH + 5
ENDIF
C Output /CROSS if needed
IF (CMD .NE. 'Message' .AND. CMD .NE. 'Bliss') THEN
IF (TEST_SWITCH(CROSS_FLAG,LOCAL_FLAGS(FILE_POINTER)) .OR.
1 (.NOT. TEST_SWITCH(NOCROSS_FLAG,LOCAL_FLAGS(FILE_POINTER))
1 .AND. TEST_SWITCH(CROSS_FLAG,GLOBAL_FLAGS))) THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+7) = '/CROSS'
CMD_LENGTH = CMD_LENGTH + 6
ENDIF
ENDIF
C Output /DEBUG switch if needed
IF (CMD .NE. 'Message') THEN
IF (TEST_SWITCH(DEB_FLAG,LOCAL_FLAGS(FILE_POINTER)) .OR.
1 (.NOT. TEST_SWITCH(NODEB_FLAG,LOCAL_FLAGS(FILE_POINTER))
1 .AND. TEST_SWITCH(DEB_FLAG,GLOBAL_FLAGS))) THEN
IF (CMD .EQ. 'Macro') THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+14) = '/ENABLE=DEBUG'
CMD_LENGTH = CMD_LENGTH + 13
ELSE
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+7) = '/DEBUG'
CMD_LENGTH = CMD_LENGTH + 6
ENDIF
ENDIF
ENDIF
C Output the object file name here
J = INDEX(FILE_NAME(FILE_POINTER),' ')
IF (J .EQ. 0) J = 10
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+J+9) = '/OBJECT='//
1 FILE_NAME(FILE_POINTER)(1:J-1)
CMD_LENGTH = CMD_LENGTH + J + 8
1200 J = INDEX(FILE_SPEC(FILE_POINTER),' ')
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+J+1) =
1 FILE_SPEC(FILE_POINTER)(1:J-1)
CMD_LENGTH = CMD_LENGTH + J - 1
C Output the /LIBRARY switch if needed
IF (TEST_SWITCH(LIBR_FLAG,LOCAL_FLAGS(FILE_POINTER))) THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+8) = '/LIBRARY'
CMD_LENGTH = CMD_LENGTH + 8
ENDIF
IF (TEST_SWITCH(CONCAT_FLAG,LOCAL_FLAGS(FILE_POINTER))) THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+1) = '+'
CMD_LENGTH = CMD_LENGTH + 1
FILE_POINTER = FILE_POINTER + 1
IF (FILE_POINTER .GT. NUMBER_FILES) CALL LIB$SIGNAL(CML_INTERR)
GOTO 1200 !Get the next concatenated file
ENDIF
WRITE(1,1110) CMD(1:I-1),FILE_NAME(FILE_POINTER)
1110 FORMAT('$ WRITE SYS$OUTPUT "',A<I-1>,': ',A9,'"')
WRITE(1,1250) CMD_LINE(1:CMD_LENGTH)
1250 FORMAT(A<CMD_LENGTH>)
1999 FILE_POINTER = FILE_POINTER + 1
IF (FILE_POINTER .LE. NUMBER_FILES) GOTO 1100
C Is the command 'COMPILE'?
IF (COMMAND .EQ. 1) GOTO 9999 !Don't link if not requested
C Need to link the modules together
WRITE (1,2000)
2000 FORMAT('$ WRITE SYS$OUTPUT "Link: Loading"')
FILE_POINTER = 1 !Start at the beginning
CMD_LINE = '$ LINK ' !Start the command line
CMD_LENGTH = 7
EXNAME = ' '
IF (COMMAND .EQ. 4) THEN !If command was 'DEBUG'
CMD_LINE(7:13) = '/DEBUG '
CMD_LENGTH = 13
ENDIF
C See if an executable qualifier was given
IF (TEST_SWITCH(EXE_FLAG,GLOBAL_FLAGS)) THEN
RET_STATUS = STR$TRIM(QUAL_VALUE(EXE_FLAG-31),
1 QUAL_VALUE(EXE_FLAG-31),I) !Find length of the exe string
CMD_LINE(CMD_LENGTH:CMD_LENGTH+12) = '/EXECUTABLE='
CMD_LENGTH = CMD_LENGTH + 12
CMD_LINE(CMD_LENGTH:CMD_LENGTH+I) =
1 QUAL_VALUE(EXE_FLAG-31)(1:I)
EXNAME = QUAL_VALUE(EXE_FLAG-31)(1:I)
CMD_LENGTH = CMD_LENGTH + I
ENDIF
C Now see if the /LINK qualifier was given
IF (TEST_SWITCH(LINK_FLAG,GLOBAL_FLAGS)) THEN
RET_STATUS = STR$TRIM(FIELD,QUAL_VALUE(LINK_FLAG-31),I)
IF (FIELD(1:1) .NE. '(' .OR. (FIELD(1:1) .EQ. '(' .AND.
1 FIELD(2:2) .NE. '/')) THEN
CMD_LINE(CMD_LENGTH:CMD_LENGTH) = '/' !Output the leading slash
CMD_LENGTH = CMD_LENGTH + 1
ENDIF
J = 1
IF (FIELD(1:1) .EQ. '(') THEN
J = 2
I = I - 1
ENDIF
CMD_LINE(CMD_LENGTH:CMD_LENGTH + I) = FIELD(J:I)
CMD_LENGTH = CMD_LENGTH + I
IF (J .EQ. 2) CMD_LENGTH = CMD_LENGTH - 1
ENDIF
2100 IF (.NOT. TEST_SWITCH(CONCAT_FLAG,LOCAL_FLAGS(FILE_POINTER)))
1 THEN
IF (TEST_SWITCH(RECOMP_FLAG,LOCAL_FLAGS(FILE_POINTER))) THEN
FIELD = FILE_NAME(FILE_POINTER)
ELSE
FIELD = FILE_SPEC(FILE_POINTER)
ENDIF
J = INDEX(FIELD,' ')
IF (J .EQ. 0) J = 10
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+J+1) =
1 FIELD(1:J-1)
CMD_LENGTH = CMD_LENGTH + J - 1
C If this is a library file, output the /LIBRARY switch to LINK
C If not, set the executable file name if necessary
IF (TEST_SWITCH(LIBR_FLAG,LOCAL_FLAGS(FILE_POINTER))) THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+8) = '/LIBRARY'
CMD_LENGTH = CMD_LENGTH + 8
ELSE
IF (EXNAME .EQ. ' ') EXNAME = FILE_NAME(FILE_POINTER)
ENDIF
IF (FILE_POINTER .LT. NUMBER_FILES) THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+1) = ','
CMD_LENGTH = CMD_LENGTH + 1
IF (CMD_LENGTH .GE. 70) THEN
CMD_LINE(CMD_LENGTH+1:CMD_LENGTH+1) = '-' !Request continuation
CMD_LENGTH = CMD_LENGTH + 1
WRITE(1,1250) CMD_LINE(1:CMD_LENGTH) !Write the record
CMD_LINE = ' ' !Clear the command line
CMD_LENGTH = 0
ENDIF
ENDIF
ENDIF
FILE_POINTER = FILE_POINTER + 1 !Step to the next file
IF (FILE_POINTER .LE. NUMBER_FILES) GOTO 2100
WRITE(1,1250) CMD_LINE(1:CMD_LENGTH) !No more files; output the command
J = INDEX(EXNAME,' ')
IF (J .EQ. 0) J = 10
IF (COMMAND .EQ. 3) WRITE(1,2200) EXNAME(1:J-1)
2200 FORMAT('$ WRITE SYS$OUTPUT "[',A<J-1>,' execution]"')
IF (COMMAND .EQ. 4) WRITE(1,2210)
2210 FORMAT('$ WRITE SYS$OUTPUT "[DEBUG execution]"')
9999 IF (COMMAND .GE. 3) WRITE(1,10005)
10005 FORMAT('$ ASSIGN/USER TT: SYS$INPUT')
IF (COMMAND .GE. 3) WRITE(1,10010) EXNAME(1:J-1)
10010 FORMAT('$ RUN ',A<J-1>)
CLOSE(UNIT=1)
RET_STATUS = STR$TRIM(FIELD,BUFFER,J)
IF (NEW_COMMAND) STAT = LIB$SET_SYMBOL('SVC',FIELD(1:J),
1 LIB$K_CLI_GLOBAL_SYM)
CALL LIB$DO_COMMAND('@COMPTMP')
CALL EXIT
END
SUBROUTINE SET_SWITCH(SWITCH,FLAGS)
IMPLICIT NONE
INTEGER*4 SWITCH, FLAGS
INTEGER*4 LIB$EXTZV
EXTERNAL CML_CNFQUAL
C This subroutine sets the appropriate bits in the flags word as
C determined by the value in SWITCH. The values are determined in
C the keyword tables in GETFILE.MAR.
C First handle the language switches
IF (SWITCH .LT. 32) THEN !See if more than one switch given,
IF (LIB$EXTZV(0,5,FLAGS) .NE. 0) CALL LIB$SIGNAL(CML_CNFQUAL)
CALL LIB$INSV(SWITCH,0,5,FLAGS) !and set the switch
RETURN
ENDIF
C Now set bits needing to be set
IF (SWITCH .LT. 64) THEN
CALL LIB$INSV(1,SWITCH-16,1,FLAGS)
RETURN
ENDIF
C Now clear the bits needing to be cleared
CALL LIB$INSV(0,SWITCH-48,1,FLAGS)
RETURN
ENTRY CLEAR_SWITCH(SWITCH,FLAGS)
IF (SWITCH .GE. 32 .AND. SWITCH .LT. 64)
1 CALL LIB$INSV(0,SWITCH-16,1,FLAGS)
RETURN
END
LOGICAL*1 FUNCTION TEST_SWITCH(SWITCH,FLAGS)
IMPLICIT NONE
INTEGER*4 SWITCH, FLAGS, LIB$EXTZV
C This subroutine extracts a binary flag from the FLAGS longword. The
C number of the flag is in argument SWITCH
TEST_SWITCH = LIB$EXTZV(SWITCH-16,1,FLAGS)
RETURN
END