!+++ ! ! TPU_CALLUSER.BAS ! ! Tom Williams (many years ago) ! ! This routine will take a "call" string from TPU and process ! it with the aid of CALL_DYNAMIC, a function to call ANY ! specified universal routine in a shareable image library. ! ! The call string is of the format ! ! "filespec>routine [p1 [, ..., pN]]" ! ! Parameters can be either strings or longwords; strings are ! passed to this procedure in quotes. For the call, strings ! are passed by descriptor; integers, by reference. ! ! Parameters can also be variables and/or literals. Variables ! can be initialized with literals. ! ! Type Format Example ! ---- ----------------------- ------------------------------ ! Var name$ or name% LIBRTL>LIB$GET_INPUT A$ ! Lit "string" or nnnnn LIBRTL>LIB$PUT_OUTPUT "Hello" ! Var/Lit Var = Lit LIBRTL>LIB$EDIT INSTR$="AbCdE" ! ! NOTE: The "Var = Literal" syntax has not been fully tested, ! and I don't even know if it works at all any more. -TWW 1/18/93 !--- SUB TPU$CALLUSER( INTEGER STAT, & STRING ROUTINE_CALL, & RESULT) OPTION TYPE = EXPLICIT, & CONSTANT TYPE = INTEGER, & SIZE = INTEGER LONG EXTERNAL LONG CONSTANT SS$_DEBUG EXTERNAL LONG FUNCTION CALL_DYNAMIC EXTERNAL STRING FUNCTION EXTRACT_TO_FIRST DECLARE LONG FUNCTION NUMERIC DECLARE STRING FUNCTION SUFFIX DECLARE LONG CONSTANT TRUE = -1, & FALSE = 0 DECLARE LONG ! & ! Argument list for LIB$CALLG. & ! & ARG_LIST( 255), & ! & ! Array of potential integer & ! arguments. & ! & INTEGER_ARG( 255), & ! & ! Miscellaneous & ! & INDEX, & IT_IS_THERE, & TEMP_LONG DECLARE STRING ! & ! Local copy of the input & ! string PROCEDURE_CALL. & ! & INPUT_STRING, & ! & ! Array of potential string & ! arguments. & ! & STRING_ARG( 255), & ! & ! Variable names. Null if & ! literal. & ! & VAR_NAME( 255), & ! & ! Miscellaneous & ! & FILE_SPEC, & ROUTINE_NAME, & TEMP_STRING !+++ ! ! Executable code. ! !--- ! ! Trim leading and trailing spaces, Reduce white space to 1 space, ! Convert lowercase to uppercase, but leave quoted substrings alone. ! INPUT_STRING = EDIT$( ROUTINE_CALL, 440) FILE_SPEC = EXTRACT_TO_FIRST( ">", INPUT_STRING) FILE_SPEC = "LIBRTL" IF FILE_SPEC == "" ROUTINE_NAME = EXTRACT_TO_FIRST( " ", INPUT_STRING) GO SUB EXTRACT_ARGUMENT_LIST STAT = CALL_DYNAMIC( ROUTINE_NAME, FILE_SPEC, ARG_LIST( 0)) GO SUB BUILD_RESULT EXIT SUB EXTRACT_ARGUMENT_LIST: INDEX, ARG_LIST( 0) = 0 IT_IS_THERE = TRUE ! Pre-load to force one iteration. WHILE IT_IS_THERE ! ! Check to see if we need another iteration. ! IT_IS_THERE = POS( INPUT_STRING, ",", 1) ! ! Increment the argument count. ! INDEX, ARG_LIST( 0) = ARG_LIST( 0) + 1 ! ! Adjust for a single argument (no commas) ! IF IT_IS_THERE THEN ! ! Extract the argument. Delete it (and the comma delimiter) ! from the input string. ! STRING_ARG( INDEX) = EDIT$( SEG$( INPUT_STRING, & 1, & IT_IS_THERE - 1), & 136) INPUT_STRING = SEG$( INPUT_STRING, & IT_IS_THERE + 1, & LEN( INPUT_STRING)) ELSE ! ! This is the last argument in the list. The remainder ! of the input string becomes the last argument. ! STRING_ARG( INDEX) = EDIT$( INPUT_STRING, 136) INPUT_STRING = "" END IF ! ! Determine variable name and/or constant value. Put ! in appropriate argument list area. ! GO SUB FORMAT_ARGUMENT NEXT RETURN FORMAT_ARGUMENT: ! ! Trim leading and trailing white space. ! STRING_ARG( INDEX) = EDIT$( STRING_ARG( INDEX), 136) ! ! Check for a Null argument. ! IF STRING_ARG( INDEX) == "" THEN ! ! Yup, it's null all right. Put a literal zero ! in the argument list. ! ARG_LIST( INDEX) = 0 ELSE ! ! Check for a purely quoted string. ! TEMP_STRING = SEG$( STRING_ARG( INDEX), 1, 1) & + SEG$( STRING_ARG( INDEX), & LEN( STRING_ARG( INDEX)), & LEN( STRING_ARG( INDEX))) IF ( TEMP_STRING = "''") OR ( TEMP_STRING = '""') THEN ! ! We have a quoted literal. Put it in the argument area, ! sans quotes. ! STRING_ARG( INDEX) = SEG$( STRING_ARG( INDEX), & 2, & LEN( STRING_ARG( INDEX)) - 1) ARG_LIST( INDEX) = LOC( STRING_ARG( INDEX)) ELSE IF NUMERIC( STRING_ARG( INDEX)) THEN ! ! We have a numeric (integer) literal. Exploit ! the side-effect creation of TEMP_LONG by the internal ! function NUMERIC. ! INTEGER_ARG( INDEX) = TEMP_LONG ARG_LIST( INDEX) = LOC( INTEGER_ARG( INDEX)) STRING_ARG( INDEX) = "" ELSE ! ! Look for either a terminating "%" or "$", ! which indicates a naked variable. ! SELECT SUFFIX( STRING_ARG( INDEX)) CASE "%" ! ! An integer variable. Save the name. ! Zero out the integer argument, which will ! be pointed to from the argument list. ! ! We'll keep the suffix to determine ! the data type to return after the call. ! VAR_NAME( INDEX) = STRING_ARG( INDEX) STRING_ARG( INDEX) = "" INTEGER_ARG( INDEX) = 0 ARG_LIST( INDEX) = LOC( INTEGER_ARG( INDEX)) CASE "$" ! ! A string variable. Save the name. ! Clear the string, which will be ! pointed to from the argument list. ! ! We'll keep the suffix to determine ! the data type to return after the call. ! VAR_NAME( INDEX) = STRING_ARG( INDEX) STRING_ARG( INDEX) = "" ARG_LIST( INDEX) = LOC( STRING_ARG( INDEX)) !CASE ELSE Set up fixed-length strings END SELECT END IF END IF END IF RETURN DEF LONG NUMERIC( STRING TEMP) NUMERIC = TRUE ! Assume the best. ON ERROR GO TO NONNUMERIC TEMP_LONG = VAL( TEMP) EXIT DEF NONNUMERIC: ! ! Error trap for non-integer strings. ! NUMERIC = FALSE RESUME EXIT_NUMERIC EXIT_NUMERIC: END DEF BUILD_RESULT: RESULT = "" FOR INDEX = 1 TO ARG_LIST( 0) ! For each argument SELECT SUFFIX( VAR_NAME( INDEX)) CASE "$" RESULT = RESULT & + SEG$( VAR_NAME( INDEX), 1, & LEN( VAR_NAME( INDEX)) - 1) & + ' := "' & + STRING_ARG( INDEX) & + '"; ' CASE "%" RESULT = RESULT & + SEG$( VAR_NAME( INDEX), 1, & LEN( VAR_NAME( INDEX)) - 1) & + ' := ' & + NUM1$( INTEGER_ARG( INDEX)) & + '; ' END SELECT NEXT INDEX RETURN DEF STRING SUFFIX( STRING TEMP) = SEG$( TEMP, LEN( TEMP), LEN( TEMP)) END SUB FUNCTION STRING EXTRACT_TO_FIRST( STRING TARGET, SOURCE) DECLARE LONG IT_IS_THERE IT_IS_THERE = POS( SOURCE, TARGET, 1) IF IT_IS_THERE THEN ! ! Success. Extract (and trim) the target from the source string. ! EXTRACT_TO_FIRST = SEG$( SOURCE, 1, IT_IS_THERE - 1) SOURCE = SEG$( SOURCE, IT_IS_THERE + 1, LEN( SOURCE)) ELSE ! ! What the bleep. Take a default. ! EXTRACT_TO_FIRST = "" END IF END FUNCTION