SUBROUTINE CLI C C FUNCTIONAL DESCRIPTION: C C Uses Niel Kempson's routines to extract the command line information C C DUMMY ARGUMENTS: C C none C C IMPLICIT INPUTS: C C none C C IMPLICIT OUTPUTS: C C All values in COMMON/GINOTOSIX/ initialized C C C SIDE EFFECTS: C C none C C IMPLICIT NONE INCLUDE '($SSDEF)' INCLUDE '($NAMDEF)' INTEGER*4 SEGMENT !Segment number in saved drawing REAL*4 WIDTH !Desired width REAL*4 HEIGHT !Desired height REAL*4 SCALE !Desired scale factor CHARACTER*255 INPUT !Name of input file CHARACTER*255 OUTPUT !Name of output file LOGICAL FORMFEED !Do we want a formfeed at the end of the !file? COMMON/GINOTOSIX/INPUT,OUTPUT,WIDTH,HEIGHT,SCALE,SEGMENT,FORMFEED INTEGER*4 CLI_STATUS INTEGER*4 CLI_STRING_LENGTH INTEGER*4 FILE_NAME_STATUS_BITS INTEGER*4 INPUT_LENGTH INTEGER*4 OUTPUT_LENGTH INTEGER*4 OUTPUT__LENGTH INTEGER*4 PARSE_STATUS INTEGER*4 F_DOLLAR_PARSE CHARACTER*255 CLI_STRING CHARACTER*255 OUTPUT_ CHARACTER*255 DEFAULT_FILESPEC CHARACTER*255 DEFAULT_NAME INTEGER*4 DEFAULT_NAME_LENGTH INTEGER*4 DEFAULT_TYPE_LENGTH INTEGER*4 DEFAULT_FILESPEC_LENGTH PARAMETER PARSE_CONCEAL = 0 PARAMETER PARSE_NOCONCEAL = 1 PARAMETER PARSE_SYNTAX_ONLY = 2 PARAMETER PARSE_CHECK_EXISTS = 0 EXTERNAL CLI$PRESENT EXTERNAL CLI$GET_VALUE INTEGER*4 CLI$PRESENT INTEGER*4 CLI$GET_VALUE EXTERNAL CLI$_PRESENT EXTERNAL CLI$_ABSENT EXTERNAL CLI$_NEGATED EXTERNAL CLI$_COMMA SEGMENT = 0 CLI_STATUS = CLI$PRESENT ('SEGMENT') IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN CLI_STATUS = CLI$GET_VALUE ('SEGMENT', 1 CLI_STRING, 1 CLI_STRING_LENGTH) IF (CLI_STATUS .EQ. SS$_NORMAL) THEN READ (CLI_STRING(1:CLI_STRING_LENGTH), 110) SEGMENT ELSE TYPE *,'GINOTOSIX Error - Invalid segment' STOP END IF IF (SEGMENT.LT.0) THEN TYPE *,'GINOTOSIX Error - Invalid segment' STOP END IF END IF SCALE = 0 CLI_STATUS = CLI$PRESENT ('SCALE') IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN CLI_STATUS = CLI$GET_VALUE ('SCALE', 1 CLI_STRING, 1 CLI_STRING_LENGTH) IF (CLI_STATUS .EQ. SS$_NORMAL) THEN READ (CLI_STRING(1:CLI_STRING_LENGTH), 100, ERR=200) SCALE ELSE 200 TYPE *,'GINOTOSIX Error - Invalid scale' STOP END IF END IF WIDTH = 0 HEIGHT = 0 CLI_STATUS = CLI$PRESENT ('SIZE') IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN CLI_STATUS = CLI$GET_VALUE ('SIZE.WIDTH', 1 CLI_STRING, 1 CLI_STRING_LENGTH) IF (CLI_STATUS .EQ. SS$_NORMAL) THEN READ (CLI_STRING(1:CLI_STRING_LENGTH), 100) WIDTH ELSE TYPE *,'GINOTOSIX Error - Invalid width' STOP END IF CLI_STATUS = CLI$GET_VALUE ('SIZE.HEIGHT', 1 CLI_STRING, 1 CLI_STRING_LENGTH) IF (CLI_STATUS .EQ. SS$_NORMAL) THEN READ (CLI_STRING(1:CLI_STRING_LENGTH), 100) HEIGHT ELSE TYPE *,'GINOTOSIX Error - Invalid height' STOP END IF END IF CLI_STATUS = CLI$PRESENT ('OUTPUT') IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) THEN CLI_STATUS = CLI$GET_VALUE ( 1 'OUTPUT', 1 OUTPUT_, 1 OUTPUT__LENGTH) PARSE_STATUS = F_DOLLAR_PARSE( 1 OUTPUT_(1:OUTPUT__LENGTH), 1 '*.*;*', 1 'FULL', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 OUTPUT, 1 OUTPUT_LENGTH, 1 FILE_NAME_STATUS_BITS) IF (IAND(FILE_NAME_STATUS_BITS, NAM$M_WILD_DIR) .NE. 0) THEN TYPE *,'GINOTOSIX Error - Illegal output filespec' STOP END IF ELSE OUTPUT(1:7) = '[]*.*;*' OUTPUT(8:) = ' ' OUTPUT_LENGTH = 7 END IF CALL REMOVE_WILDCARDS (OUTPUT, OUTPUT_LENGTH) CLI_STATUS = CLI$GET_VALUE('INPUT_FILESPEC', 1 INPUT, 1 INPUT_LENGTH) IF (CLI_STATUS .NE. SS$_NORMAL) THEN TYPE *,'GINOTOSIX Error - Illegal input filespec' STOP END IF PARSE_STATUS = F_DOLLAR_PARSE ( 1 INPUT(1:INPUT_LENGTH), 1 '.PIC', 1 'FULL', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 INPUT, 1 INPUT_LENGTH, 1 FILE_NAME_STATUS_BITS) PARSE_STATUS = F_DOLLAR_PARSE (INPUT, 1 ' ', 1 'NAME', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 DEFAULT_NAME, 1 DEFAULT_NAME_LENGTH, 1 FILE_NAME_STATUS_BITS) DEFAULT_FILESPEC = DEFAULT_NAME(1:DEFAULT_NAME_LENGTH) // '.SIX' DEFAULT_FILESPEC_LENGTH = DEFAULT_NAME_LENGTH + 4 PARSE_STATUS = F_DOLLAR_PARSE ( 1 OUTPUT(1:OUTPUT_LENGTH), 1 DEFAULT_FILESPEC(1:DEFAULT_FILESPEC_LENGTH), 1 'FULL', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 OUTPUT, 1 OUTPUT_LENGTH, 1 FILE_NAME_STATUS_BITS) IF (IAND (FILE_NAME_STATUS_BITS, NAM$M_WILDCARD) .NE. 0) THEN CALL REMOVE_WILDCARDS (OUTPUT, OUTPUT_LENGTH) END IF FORMFEED=.FALSE. CLI_STATUS = CLI$PRESENT ('FORMFEED') IF (CLI_STATUS .EQ. %LOC (CLI$_PRESENT)) FORMFEED=.TRUE. RETURN 100 FORMAT (F5.0) 110 FORMAT (I5) END SUBROUTINE REMOVE_WILDCARDS (FILE_SPEC, FILE_SPEC_LENGTH) INCLUDE '($NAMDEF)' PARAMETER PARSE_CONCEAL = 0, 1 PARSE_NOCONCEAL = 1, 1 PARSE_SYNTAX_ONLY = 2, 1 PARSE_CHECK_EXISTS = 0 CHARACTER*(*) file_spec INTEGER*4 file_spec_length CHARACTER*255 1 new_file_spec, 1 node, 1 device, 1 directory CHARACTER*255 1 default_name, 1 default_type, 1 name, 1 type, 1 version INTEGER*4 new_file_spec_length, 1 node_length, 1 device_length, 1 directory_length, 1 name_length, 1 type_length, 1 version_length, 1 f_dollar_parse, 1 parse_status, 1 file_name_status_bits, 1 string_length file_spec_length = string_length (file_spec) parse_status = f_dollar_parse ( 1 file_spec(1:file_spec_length), 1 ' ', 1 'NODE', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 node, 1 node_length, 1 file_name_status_bits) IF (node_length .GT. 0) THEN new_file_spec(1:) = node(1:node_length) END IF new_file_spec_length = node_length parse_status = f_dollar_parse ( 1 file_spec(1:file_spec_length), 1 ' ', 1 'DEVICE', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 device, 1 device_length, 1 file_name_status_bits ) IF (device_length .GT. 0) THEN new_file_spec(new_file_spec_length+1:) = device(1:device_length) END IF new_file_spec_length = new_file_spec_length + device_length parse_status = f_dollar_parse ( 1 file_spec(1:file_spec_length), 1 ' ', 1 'DIRECTORY', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 directory, 1 directory_length, 1 file_name_status_bits) IF (IAND (file_name_status_bits, NAM$M_WILD_DIR) .EQ. 0) THEN IF (directory_length .GT. 0) THEN new_file_spec(new_file_spec_length+1:) = 1 directory(1:directory_length) END IF new_file_spec_length = new_file_spec_length + directory_length END IF parse_status = f_dollar_parse ( 1 file_spec(1:file_spec_length), 1 ' ', 1 'NAME', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 name, 1 name_length, 1 file_name_status_bits ) IF (IAND (file_name_status_bits, NAM$M_WILD_NAME) .EQ. 0) THEN IF (name_length .GT. 0) THEN new_file_spec(new_file_spec_length+1:) = name(1:name_length) END IF new_file_spec_length = new_file_spec_length + name_length END IF parse_status = f_dollar_parse ( 1 file_spec(1:file_spec_length), 1 ' ', 1 'TYPE', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 type, 1 type_length, 1 file_name_status_bits ) IF (IAND (file_name_status_bits, NAM$M_WILD_TYPE) .EQ. 0) THEN IF (type_length .GT. 0) THEN new_file_spec(new_file_spec_length+1:) = type(1:type_length) END IF new_file_spec_length = new_file_spec_length + type_length END IF parse_status = f_dollar_parse ( 1 file_spec(1:file_spec_length), 1 ' ', 1 'VERSION', 1 PARSE_CONCEAL+PARSE_SYNTAX_ONLY, 1 version, 1 version_length, 1 file_name_status_bits) IF (IAND (file_name_status_bits, NAM$M_WILD_VER) .EQ. 0) THEN IF (version_length .GT. 0) THEN new_file_spec(new_file_spec_length+1:) = 1 version(1:version_length) END IF new_file_spec_length = new_file_spec_length + version_length END IF IF (new_file_spec_length .GT. 0) THEN file_spec(1:) = new_file_spec(1:new_file_spec_length) END IF file_spec_length = new_file_spec_length RETURN END INTEGER*4 FUNCTION f_dollar_parse (file_spec, 1 default_file_spec, 1 parse_type, 1 parse_flags, 1 return_buffer, 1 return_string_length, 1 file_name_status_bits) INCLUDE '($FABDEF)' INCLUDE '($NAMDEF)' PARAMETER PARSE_CONCEAL = 0, 1 PARSE_NOCONCEAL = 1, 1 PARSE_SYNTAX_ONLY = 2, 1 PARSE_CHECK_EXISTS = 0 CHARACTER*(*) file_spec, 1 default_file_spec, 1 return_buffer, 1 parse_type INTEGER*4 return_string_length, 1 parse_flags, 1 file_name_status_bits RECORD /FABDEF/ fab RECORD /NAMDEF/ nam CHARACTER*16 local_parse_type CHARACTER*255 1 full_filespec INTEGER*4 SYS$PARSE, 1 start_char, 1 stop_char, 1 return_buffer_size, 1 parsed_string_length BYTE int_to_byte fab.FAB$B_BID = FAB$C_BID fab.FAB$B_BLN = FAB$C_BLN fab.FAB$L_FNA = %LOC (file_spec) fab.FAB$B_FNS = int_to_byte (LEN (file_spec)) fab.FAB$L_DNA = %LOC (default_file_spec) fab.FAB$B_DNS = int_to_byte (LEN (default_file_spec)) fab.FAB$L_NAM = %LOC (nam) nam.NAM$B_BID = NAM$C_BID nam.NAM$B_BLN = NAM$C_BLN nam.NAM$L_ESA = %LOC (full_filespec) nam.NAM$B_ESS = int_to_byte (MIN (LEN (full_filespec), 255)) nam.NAM$B_NOP = 0 IF (IAND (parse_flags, PARSE_NOCONCEAL) .NE. 0) THEN nam.NAM$B_NOP = NAM$M_NOCONCEAL END IF IF (IAND (parse_flags, PARSE_SYNTAX_ONLY) .NE. 0) THEN nam.NAM$B_NOP = nam.NAM$B_NOP + NAM$M_SYNCHK END IF f_dollar_parse = SYS$PARSE (fab) file_name_status_bits = nam.NAM$L_FNB CALL STR$UPCASE (local_parse_type, parse_type) IF (local_parse_type .EQ. 'NODE') THEN start_char = nam.NAM$L_NODE - nam.NAM$L_ESA + 1 stop_char = start_char + ZEXT (nam.NAM$B_NODE) - 1 ELSE IF (local_parse_type .EQ. 'DEVICE') THEN start_char = nam.NAM$L_DEV - nam.NAM$L_ESA + 1 stop_char = start_char + ZEXT (nam.NAM$B_DEV) - 1 ELSE IF (local_parse_type .EQ. 'DIRECTORY') THEN start_char = nam.NAM$L_DIR - nam.NAM$L_ESA + 1 stop_char = start_char + ZEXT (nam.NAM$B_DIR) - 1 ELSE IF (local_parse_type .EQ. 'NAME') THEN start_char = nam.NAM$L_NAME - nam.NAM$L_ESA + 1 stop_char = start_char + ZEXT (nam.NAM$B_NAME) - 1 ELSE IF (local_parse_type .EQ. 'TYPE') THEN start_char = nam.NAM$L_TYPE - nam.NAM$L_ESA + 1 stop_char = start_char + ZEXT (nam.NAM$B_TYPE) - 1 ELSE IF (local_parse_type .EQ. 'VERSION') THEN start_char = nam.NAM$L_VER - nam.NAM$L_ESA + 1 stop_char = start_char + ZEXT (nam.NAM$B_VER) - 1 ELSE IF (local_parse_type .EQ. 'FULL') THEN start_char = 1 stop_char = ZEXT (nam.NAM$B_ESL) ELSE TYPE *, 'Invalid parse string: (',local_parse_type,').' CALL LIB$SIGNAL (MODIFY$INVPARTYP, 1, local_parse_type) CALL EXIT END IF parsed_string_length = stop_char - start_char + 1 return_buffer_size = LEN (return_buffer) return_string_length = MIN (return_buffer_size, parsed_string_length) IF (return_string_length .GT. 0) THEN return_buffer(1:) = full_filespec( 1 start_char:start_char + return_string_length - 1) END IF RETURN END INTEGER*4 FUNCTION string_length (string) IMPLICIT NONE CHARACTER*(*) string CHARACTER this_char string_length = LEN (string) DO WHILE (string_length .GT. 0) this_char = string(string_length:string_length) IF ((this_char .NE. ' ') .AND. (this_char .NE. CHAR(9))) THEN RETURN END IF string_length = string_length - 1 END DO RETURN END BYTE FUNCTION int_to_byte (number) IMPLICIT NONE INTEGER*4 number IF ( IAND (number, '00000080'X) .NE. 0) THEN int_to_byte = IOR (number, 'FFFFFF00'X) ELSE int_to_byte = IAND (number, '000000FF'X) END IF RETURN END