.ENABL LC .TITLE POS .IDENT /V1.B/ ; Title: MACRO-11 version of BASIC POS function. ; Routine Name: POS ; File Name: [377,2]POS.MAC ; Author: B.Hillam ; Library Name: ADDLIB ; ; Description: ; This is a MACRO-11 version of a subroutine originally ; written by R.C.Morrey to allow FORTRAN programs to use the ; equivalent of the BASIC POS function. It scans the string ; STR1 looking for the first occurrence of another string, ; and returns the FORTRAN array index corresponding to the ; position of the first character. If the second string was ; not found, a value of zero is returned. ; Optional parameters allow the string being searched ; for to be specified as a substring of another string. ; ; If the routine is called as POS, the calling programme ; MUST declare POS as an INTEGER. To avoid problems, call the ; routine as IPOS. ; ; Subsidiary HELP qualifiers: ; ; PARAMETERS STATUS EXAMPLES ;3 STATUS ; Modification List: ; 1.A Date: 27-FEB-81 ORIGINAL ; 1.B Date: 13-MAR-83 ; Add IPOS entry point. ; Restrictions: ; If the lengths of the strings are omitted, they must end in a null, ; and must not exceed 256 characters in length ;3 PARAMETERS ; Calling Sequence: ; Parameters in square brackets are optional, but appropriate ; number of commas must be inserted if parameters follow. ; Missing parameters at the end of the list need not have commas in. ; I=IPOS( STR1, [ISTR1] , STR2 [, [ISTR2] [,[ISTART]] [,[IFIN]]]) ; External Routines called: ; LB:[1,1]ADDLIB/LB:LEN via $SCAN entry point. ; Parameter List: ; Inputs : ; STR1 LOGICAL*1 array or Hollerith string containing the string ; being checked. ; Must end in null (0) if character count is omitted. ; ISTR1 INTEGER*2 character count for STR1. This parameter ; is optional, but STR1 must end in null if it is ; omitted or is zero. ; STR2 LOGICAL*1 array or Hollerith string containing the string ; to search for in STR1. ; Must end in null (0) if character count is omitted. ; ; Type HELP ADDLIB POS PARAMETERS MORE for rest of parameter data ;4 MORE ; ISTR2 INTEGER*2 character count for STR2. This parameter ; is optional, but STR2 must end in null if it is ; omitted or is zero. ; ISTART INTEGER*2 optional parameter containing the position in ; STR2 at which the required substring starts. ; Defaults to 1 if omitted, 0 or negative. ; IFIN INTEGER*2 optional parameter containing the position in ; STR2 at which the required substring finishes. ; Defaults to the last character in STR2 if omitted, 0 ; or negative. ; Outputs: ; IPOS ; POS INTEGER*2 return via function, giving start position ; of STR2 (or substring of STR2) in STR1. ; 0 if STR2 not found in STR1, STR1 length <= 0, ; STR2 substring longer than STR1, or STR2 substring ; length <= 0. ; All input parameters are unchanged. ; Common Blocks: ; NONE ;3 EXAMPLES ; Example calls to POS ; -------------------- ; I=IPOS(STR1,7,STR2,5,2,3) ; J=IPOS(STR1,,'JIM') ; K=IPOS(STR1,6,'FRED') ; L=IPOS('ABCDEFGHIJ',,STR2,6,3) ; ;END ; ; Define offsets for parameter list. ; STR1=2 ISTR1=4 STR2=6 ISTR2=8. ISTART=10. IFIN=12. ; NULARG=-1 ;Define null argument. ; ; Define offsets for stack workspace ; RESULT=0 FINISH=2 START=4 STR2L=6 STR1L=8. ; .PSECT $CODE1,RO,I,CON,LCL,REL ; IPOS:: POS:: CMP ISTR1(R5),#NULARG ;Is string 1 length parameter missing ? BEQ 1$ ;EQ if yes MOV @ISTR1(R5),-(SP) ;Get string 1 length BGT 2$ ;OK if +ve TST (SP)+ ; 1$: MOV STR1(R5),R1 ;Get string 1 start address CALL $SCAN ;Evaluate length MOV R2,-(SP) ;Store it 2$: CMPB (R5),#4 ;4 arguments supplied ? BLT 3$ ;LT if no. CMP ISTR2(R5),#NULARG ;Is string 2 length parameter missing ? BEQ 3$ ;EQ if yes MOV @ISTR2(R5),-(SP) ;Get string 2 length BGT 4$ ;OK if +ve TST (SP)+ ; 3$: MOV STR2(R5),R1 ;Get string 2 start address CALL $SCAN ;Evaluate length MOV R2,-(SP) ;Store it 4$: MOV (SP),R2 ;Get string 2 length for later CMPB (R5),#5 ;Are there 5 arguments supplied ? BLT 5$ ;LT if no CMP ISTART(R5),#NULARG ;Is substring start parameter missing ? BEQ 5$ ;EQ if yes MOV @ISTART(R5),-(SP) ;Get substring start. BGT 6$ ;OK if +ve TST (SP)+ 5$: MOV #1,-(SP) ;Give default start of 1 6$: CMPB (R5),#6 ;6 arguments supplied ? BLT 7$ ;LT if no CMP IFIN(R5),#NULARG ;Substring finish parameter ? BEQ 7$ ;EQ if no MOV @IFIN(R5),-(SP) ;Get substring finish BGT 8$ ;OK if +ve TST (SP)+ 7$: MOV R2,-(SP) ;Give default of string 2 length 8$: MOV STR1(R5),-(SP) ;Get string 1 start address SUB START(SP),FINISH(SP) INC FINISH(SP) ;Character count for substring BLE 12$ ;Exit if <= 0 CMP FINISH(SP),STR2L(SP) ;Compare with full length BGT 12$ ;Exit if > than full string ADD STR2(R5),START(SP) DEC START(SP) ;Start address of substring CMP STR2L(SP),STR1L(SP) BGT 12$ ;String 2 bigger than string 1 MOV STR1L(SP),R1 BLE 12$ ;Trap null STR1 SUB FINISH(SP),R1 ;Evaluate number of times STR2 INC R1 ;needs to be tested against STR1 BLE 12$ ;Trap length conflict 9$: MOV RESULT(SP),R0 ;Get current string 1 pointer MOV START(SP),R2 ;Get start address of string 2 MOV FINISH(SP),R3 ;Get character count for string 2 10$: CMPB (R0)+,(R2)+ ;Compare characters BNE 11$ ;NE if no match SOB R3,10$ ;Continue for length of string 2 MOV RESULT(SP),R0 ;Get address at which match found SUB STR1(R5),R0 ;Subtract start address of string 1 INC R0 ;Evaluate FORTRAN array index. BR 13$ ;Return to caller 11$: INC RESULT(SP) ;Advance pointer for string 1 SOB R1,9$ ;Continue until end of string 1 12$: CLR R0 ;No match found. 13$: ADD #10.,SP ;Clean up stack RETURN .END