1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34DEFPARAMETER($wildCard, char "*") 35 36maskMatch?(mask,subject) == 37 null mask => true 38 if null STRINGP subject then subject := PNAME subject 39 or/[match?(pattern,subject) for pattern in mask] 40 41substring?(part, whole, startpos) == 42--This function should be replaced by STRING< 43 np := SIZE part 44 nw := SIZE whole 45 np > nw - startpos => false 46 and/[CHAR_-EQUAL(ELT(part, ip), ELT(whole, iw)) 47 for ip in 0..np-1 for iw in startpos.. ] 48 49anySubstring?(part,whole,startpos) == 50 np := SIZE part 51 nw := SIZE whole 52 or/[((k := i) and and/[CHAR_-EQUAL(ELT(part, ip),ELT(whole, iw)) 53 for ip in 0..np - 1 for iw in i..]) for i in startpos..nw - np] => k 54 55charPosition(c,t,startpos) == 56 n := SIZE t 57 startpos < 0 or startpos > n => n 58 k:= startpos 59 for i in startpos .. n-1 repeat 60 c = ELT(t,i) => return nil 61 k := k+1 62 k 63 64rightCharPosition(c,t,startpos) == --startpos often equals MAXINDEX t (rightmost) 65 k := startpos 66 for i in startpos..0 by -1 while c ~= ELT(t,i) repeat (k := k - 1) 67 k 68 69stringPosition(s,t,startpos) == 70 n := SIZE t 71 if startpos < 0 or startpos > n then error "index out of range" 72 if SIZE s = 0 then return startpos -- bug in STRPOS 73 r := STRPOS(s,t,startpos,NIL) 74 if EQ(r,NIL) then n else r 75 76superMatch?(opattern,subject) == --subject assumed to be DOWNCASEd 77 $wildCard : local := char '_* 78 pattern := patternCheck opattern 79 logicalMatch?(pattern,subject) 80 81logicalMatch?(pattern,subject) == --subject assumed to be DOWNCASEd 82 pattern is [op,:argl] => 83 op = "and" => and/[superMatch?(p,subject) for p in argl] 84 op = "or" => or/[superMatch?(p,subject) for p in argl] 85 op = "not" => not superMatch?(first argl,subject) 86 systemError '"unknown pattern form" 87 basicMatch?(pattern,subject) 88 89patternCheck pattern == main where 90 --checks for escape characters, maybe new $wildCard 91 main == 92-- pattern := pmTransFilter pattern --should no longer need this (rdj:10/1/91) 93 u := pos(char '__,pattern) 94 null u => pattern 95 not(and/[equal(pattern,i + 1,$wildCard) for i in u]) => 96 sayBrightly ['"Invalid use of underscores in pattern: ",pattern] 97 '"!!!!!!!!!!!!!!" 98 c := wild(pattern,'(_$ _# _% _& _@)) 99-- sayBrightlyNT ['"Choosing new wild card"] 100-- pp c 101 $oldWild :local := $wildCard 102 $wildCard := c 103 pattern := mknew(pattern,first u,rest u,SUBSTRING(pattern,0,first u)) 104-- sayBrightlyNT ['"Replacing pattern by"] 105-- pp pattern 106 pattern 107 mknew(old,i,r,new) == 108 new := STRCONC(new,old.(i + 1)) --add underscored character to string 109 null r => STRCONC(new,subWild(SUBSTRING(old,i + 2,nil),0)) 110 mknew(old,first r,rest r, 111 STRCONC(new,subWild(SUBSTRING(old,i + 2,(first r) - i - 1),i + 1))) 112 subWild(s,i) == 113 (k := charPosition($oldWild,s,i)) < #s => 114 STRCONC(SUBSTRING(s,i,k - i),$wildCard,subWild(s,k + 1)) 115 SUBSTRING(s,i,nil) 116 pos(c,s) == 117 i := 0 118 n := MAXINDEX s 119 acc := nil 120 repeat 121 k := charPosition(c,s,i) 122 k > n => return NREVERSE acc 123 acc := [k,:acc] 124 i := k + 1 125 equal(p,n,c) == 126 n > MAXINDEX p => false 127 p.n = c 128 wild(p,u) == 129 for id in u repeat 130 c := char id 131 not(or/[p.i = c for i in 0..MAXINDEX(p)]) => return c 132 133match?(pattern,subject) == --returns index of first character that matches 134 basicMatch?(pattern,DOWNCASE subject) 135 136basicMatch?(pattern,target) == 137 n := #pattern 138 p := charPosition($wildCard,pattern,0) 139 p = n => (pattern = target) and 0 140 if p ~= 0 then 141 -- pattern does not begin with a wild card 142 ans := 0 143 s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] 144 not substring?(s,target,0) => return false 145 else if n = 1 then return 0 146 i := p -- starting position for searching the target 147 q := charPosition($wildCard,pattern,p+1) 148 ltarget := #target 149 while q ~= n repeat 150 s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] 151 i := stringPosition(s,target,i) 152 if null ans then ans := stringPosition(s,target,p) 153 -- for patterns beginning with wildcard, ans gives position of first match 154 if i = ltarget then return (returnFlag := true) 155 i := i + #s 156 p := q 157 q := charPosition($wildCard,pattern,q+1) 158 returnFlag => false 159 if p ~= q-1 then 160 -- pattern does not end with a wildcard 161 s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] 162 if not suffix?(s,target) then return false 163 if null ans then ans := 1 --pattern is a word preceded by a * 164 ans 165 166stringMatches?(pattern, subject) == 167 FIXP basicMatch?(pattern,subject) => true 168 false 169 170matchSegment?(pattern,subject,k) == 171 matchAnySegment?(pattern,DOWNCASE subject,k,nil) 172 173matchAnySegment?(pattern,target,k,nc) == --k = start position; nc=#chars or NIL 174 n := #pattern 175 p := charPosition($wildCard,pattern,0) 176 p = n => 177 m := stringPosition(pattern,target,k) 178 m = #target => nil 179 null nc => true 180 m <= k + nc - n 181 if k ~= 0 and nc then 182 target := SUBSTRING(target,k,nc) 183 k := 0 184 if p ~= 0 then 185 -- pattern does not begin with a wild card 186 ans := 0 187 s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] 188 not substring?(s,target,k) => return false 189 else if n = 1 then return true 190 i := p + k -- starting position for searching the target 191 q := charPosition($wildCard,pattern,p+1) 192 ltarget := #target 193 while q ~= n repeat 194 s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] 195 i := stringPosition(s,target,i) 196 if i = ltarget then return (returnFlag := true) 197 i := i + #s 198 p := q 199 q := charPosition($wildCard,pattern,q+1) 200 returnFlag => false 201 if p ~= q-1 then 202 -- pattern does not end with a '& 203 s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] 204 if not suffix?(s,target) then return false 205 if null ans then ans := 1 --pattern is a word preceded by a * 206 true 207 208infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) 209 210prefix?(s,t) == substring?(s,t,0) 211 212suffix?(s,t) == 213 m := #s; n := #t 214 if m > n then return false 215 substring?(s,t,(n-m)) 216