Listing: 1 (* Release 3.00 *) 2 3 (* Copyright (C) 1987..1991 Jensen & Partners International *) 4 5 (*# call(o_a_copy => off, near_call=>off, ds_eq_ss=>off) *) 6 (*# call(seg_name => null) *) 7 (*# module(implementation=>off, init_code=>off) *) 8 (*# data(seg_name => null, near_ptr=>off) *) 9 (*# check(stack=>off, 10 index=>off, 11 range=>off, 12 overflow=>off, 13 nil_ptr=>off) *) 14 15 IMPLEMENTATION MODULE WinStr; 16 17 IMPORT Lib, MATHLIB, SYSTEM; 18 19 PROCEDURE Compare(S1,S2:ARRAY OF CHAR):INTEGER; IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 20 PROCEDURE Length(S:ARRAY OF CHAR):CARDINAL; IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 21 PROCEDURE Concat(VAR R:ARRAY OF CHAR;S1,S2:ARRAY OF CHAR); IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 22 PROCEDURE Append(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR); IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 23 PROCEDURE Copy(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR); IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 24 PROCEDURE CharPos(S:ARRAY OF CHAR;C:CHAR):CARDINAL; IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 25 PROCEDURE Caps(VAR S:ARRAY OF CHAR); IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 26 PROCEDURE Lows(VAR S:ARRAY OF CHAR); IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 27 PROCEDURE Slice(VAR R:ARRAY OF CHAR;S:ARRAY OF CHAR;P,L:CARDINAL); IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 28 PROCEDURE Pos(S,P:ARRAY OF CHAR):CARDINAL; IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 29 PROCEDURE NextPos(S,P:ARRAY OF CHAR;Place:CARDINAL):CARDINAL; IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 30 PROCEDURE RCharPos(S:ARRAY OF CHAR;C:CHAR):CARDINAL; IN FarAsm; ***** ^ not supported yet ***** ^ not supported yet 31 32 PROCEDURE Prepend(VAR S1:ARRAY OF CHAR;S2:ARRAY OF CHAR); ***** ^ not supported yet ***** ^ not supported yet 33 VAR 34 ShiftLen : CARDINAL; 35 S1Len,S2Len : CARDINAL; 36 BEGIN 37 S1Len:=Length(S1)+1; ***** ^ not supported yet ***** ^ not supported yet 38 S2Len:=Length(S2); ***** ^ not supported yet ***** ^ not supported yet 39 IF S2Len > HIGH(S1) THEN ***** ^ undeclared identifier ***** ^ not supported yet 40 Copy(S1,S2); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 41 RETURN; 42 END; 43 ShiftLen := HIGH(S1) - S2Len + 1; ***** ^ undeclared identifier ***** ^ not supported yet 44 IF ShiftLen > S1Len THEN 45 ShiftLen := S1Len 46 END; (*IF*) 47 Lib.Move(ADR(S1),ADR(S1[S2Len]),ShiftLen); ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 48 Lib.Move(ADR(S2),ADR(S1),S2Len); ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 49 END Prepend; ***** ^ not supported yet 50 51 PROCEDURE Subst(VAR S1:ARRAY OF CHAR;Target:ARRAY OF CHAR;New:ARRAY OF CHAR); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 52 VAR 53 TargetPos, 54 TargetLen : CARDINAL; 55 BEGIN 56 TargetPos := Pos(S1,Target); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 57 IF TargetPos = MAX(CARDINAL) THEN ***** ^ undeclared identifier ***** ^ not supported yet 58 RETURN 59 END; (*IF*) 60 TargetLen := Length(Target); ***** ^ not supported yet ***** ^ not supported yet 61 Lib.Move(ADR(S1[TargetPos+TargetLen]),ADR(S1[TargetPos]),Length(S1)-TargetLen-TargetPos+1); ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 62 Insert(S1,New,TargetPos); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 63 END Subst; ***** ^ not supported yet 64 65 PROCEDURE Delete(VAR S:ARRAY OF CHAR;P,L:CARDINAL); ***** ^ not supported yet 66 VAR 67 Len,i : CARDINAL; 68 BEGIN 69 IF L # 0 THEN 70 Len := Length(S); ***** ^ not supported yet ***** ^ not supported yet 71 IF P < Len THEN 72 IF L < Len - P THEN 73 i := P+L; 74 REPEAT 75 S[P] := S[i]; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 76 INC(P); ***** ^ undeclared identifier ***** ^ not supported yet 77 INC(i); ***** ^ undeclared identifier ***** ^ not supported yet 78 UNTIL i=Len; 79 END; (*IF*) 80 S[P] := 0C; ***** ^ not supported yet ***** ^ not supported yet 81 END; (*IF*) 82 END; (*IF*) 83 END Delete; ***** ^ not supported yet 84 85 PROCEDURE Insert(VAR S1:ARRAY OF CHAR;S2:ARRAY OF CHAR;P:CARDINAL); ***** ^ not supported yet ***** ^ not supported yet 86 VAR 87 I,J,C,L : CARDINAL; 88 BEGIN 89 L := Length(S1); ***** ^ not supported yet ***** ^ not supported yet 90 I := Length(S2); ***** ^ not supported yet ***** ^ not supported yet 91 C := L; 92 IF C < P THEN 93 P := C; 94 END; (*IF*) 95 DEC(C,P); ***** ^ undeclared identifier ***** ^ not supported yet 96 FOR J := C TO 0 BY -1 DO 97 IF (J+P+I <= HIGH(S1)) THEN ***** ^ undeclared identifier ***** ^ not supported yet 98 S1[J+P+I] := S1[J+P]; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 99 END; (*IF*) 100 END; (*FOR*) 101 J := 0; 102 WHILE (J 0 DO 147 DEC(I); 148 INCL(CS,T[I]); 149 END; 150 Item(R,S,CS,N); 151 END ItemS; 152 153 PROCEDURE Match(Source,Pattern:ARRAY OF CHAR):BOOLEAN; 154 155 PROCEDURE Rmatch(VAR s:ARRAY OF CHAR;i:CARDINAL;VAR p:ARRAY OF CHAR;j:CARDINAL):BOOLEAN; 156 VAR 157 matched : BOOLEAN; 158 k : CARDINAL; 159 BEGIN 160 IF p[0]=0C THEN 161 RETURN TRUE; 162 END; (*IF*) 163 LOOP 164 IF ((i>HIGH(s)) OR (s[i]=0C)) & ((j>HIGH(p)) OR (p[j]=0C)) THEN 165 RETURN TRUE; 166 ELSIF ((j>HIGH(p)) OR (p[j]=0C)) THEN 167 RETURN FALSE; 168 ELSIF (p[j]='*') THEN 169 k :=i; 170 IF ((j=HIGH(p)) OR (p[j+1]=0C)) THEN 171 RETURN TRUE; 172 ELSE 173 LOOP 174 matched := Rmatch(s,k,p,j+1); 175 IF matched OR (k>HIGH(s)) OR (s[k]=0C) THEN 176 RETURN matched; 177 END; (*IF*) 178 INC(k); 179 END; (*LOOP*) 180 END; (*IF*) 181 ELSIF ((p[j]='?') & (s[i]#0C)) OR (CAP(p[j])=CAP(s[i])) THEN 182 INC(i); 183 INC(j); 184 ELSE 185 RETURN FALSE; 186 END; (*IF*) 187 END; (*LOOP*) 188 END Rmatch; 189 190 BEGIN (*Match*) 191 RETURN Rmatch(Source,0,Pattern,0); 192 END Match; 193 194 TYPE 195 ConvIntType = ARRAY ['0'..'F'] OF SHORTCARD; 196 BA = ARRAY[0..1] OF SHORTCARD; 197 198 CONST 199 ConvStr = '0123456789ABCDEF'; 200 ConvInt = ConvIntType( 0,1,2,3,4,5,6,7,8,9,255,255,255,255,255,255,255,10,11,12,13,14,15 ); 201 Div = BA(0,4); 202 203 PROCEDURE CheckBase(VAR b:CARDINAL); 204 BEGIN 205 IF b < 2 THEN 206 b := 2; 207 END; (*IF*) 208 IF b > 16 THEN 209 b := 16; 210 END; (*IF*) 211 END CheckBase; 212 213 PROCEDURE Reverse(VAR s: ARRAY OF CHAR; l,h: CARDINAL); 214 VAR 215 T : CHAR; 216 BEGIN 217 WHILE l < h DO 218 T := s[l]; 219 s[l] := s[h]; 220 s[h] := T; 221 INC(l); 222 DEC(h); 223 END; (*WHILE*) 224 END Reverse; 225 226 PROCEDURE IntToStr(V:LONGINT;VAR S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN); 227 VAR 228 i,l : CARDINAL; 229 b : LONGCARD; 230 BEGIN 231 OK := TRUE; 232 l := HIGH(S); 233 CheckBase(Base); 234 b := VAL(LONGCARD,Base); 235 IF V < 0 THEN 236 S[0] := '-'; 237 i := 1; 238 V := -V; 239 ELSE 240 i := 0; 241 END; (*IF*) 242 LOOP 243 IF i > l THEN 244 OK := FALSE; 245 EXIT; 246 END; (*IF*) 247 S[i] := ConvStr[CARDINAL(LONGCARD(V) MOD b)]; 248 INC(i); 249 V := LONGCARD(V) DIV b; 250 IF V = 0 THEN 251 EXIT; 252 END; (*IF*) 253 END; (*LOOP*) 254 IF i <= l THEN 255 S[i] := 0C; 256 END; (*IF*) 257 IF S[0] < '0' THEN 258 Reverse(S,1,i-1); 259 ELSE 260 Reverse(S,0,i-1); 261 END; (*IF*) 262 END IntToStr; 263 264 PROCEDURE CardToStr(V:LONGCARD;VAR S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN); 265 VAR 266 i,l : CARDINAL; 267 b : LONGCARD; 268 BEGIN 269 OK := TRUE; 270 l := HIGH(S); 271 CheckBase(Base); 272 b := VAL(LONGCARD,Base); 273 i := 0; 274 LOOP 275 IF i > l THEN 276 OK := FALSE; 277 EXIT; 278 END; (*IF*) 279 S[i] := ConvStr[CARDINAL(V MOD b)]; 280 INC(i); 281 V := V DIV b; 282 IF V = 0 THEN 283 EXIT; 284 END; (*IF*) 285 END; (*LOOP*) 286 IF i <= l THEN 287 S[i] := 0C; 288 END; (*IF*) 289 Reverse(S,0,i-1); 290 END CardToStr; 291 292 (*# save,call(o_a_copy=>off)*) 293 PROCEDURE StrToCI(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGCARD; 294 VAR 295 i,l : CARDINAL; 296 b,t,y : LONGCARD; 297 c : CHAR; 298 x : SHORTCARD; 299 BEGIN 300 CheckBase(Base); 301 b := VAL(LONGCARD,Base); 302 i := 0; 303 l := HIGH(S); 304 IF (S[0] = '-') OR (S[0] = '+') THEN 305 i := 1; 306 END; (*IF*) 307 t := 0; 308 IF S[i] = 0C THEN 309 OK := FALSE; 310 END; (*IF*) 311 WHILE (i <= l) & (S[i] # 0C) DO 312 c := S[i]; 313 IF (c < '0') OR (c > 'F') THEN 314 OK := FALSE; 315 RETURN t; 316 END; (*IF*) 317 x := ConvInt[c]; 318 IF (x > SHORTCARD(b)-1) OR (t > (MAX(LONGCARD)-LONGCARD(x)) DIV b) THEN 319 OK := FALSE; 320 END; (*IF*) 321 t := t*b+VAL(LONGCARD,x); 322 INC(i); 323 END; (*WHILE*) 324 RETURN t; 325 END StrToCI; 326 327 PROCEDURE StrToInt(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGINT; 328 VAR 329 t : LONGCARD; 330 BEGIN 331 OK := TRUE; 332 t := StrToCI(S,Base,OK); 333 IF t > 7FFFFFFFH THEN 334 OK := FALSE; 335 END; (*IF*) 336 IF S[0] = '-' THEN 337 RETURN -LONGINT(t); 338 ELSE 339 RETURN LONGINT(t); 340 END; (*IF*) 341 END StrToInt; 342 343 PROCEDURE StrToCard(S:ARRAY OF CHAR;Base:CARDINAL;VAR OK:BOOLEAN):LONGCARD; 344 VAR 345 t : LONGCARD; 346 BEGIN 347 OK := TRUE; 348 t := StrToCI(S,Base,OK); 349 IF S[0] = '-' THEN 350 OK := FALSE; 351 END; (*IF*) 352 RETURN t; 353 END StrToCard; 354 355 PROCEDURE FindSubStr(Source,Pattern: ARRAY OF CHAR;VAR pos:ARRAY OF PosLen) : BOOLEAN; 356 357 PROCEDURE Rmatch(i,j,p:CARDINAL):BOOLEAN; 358 VAR 359 matched : BOOLEAN; 360 k : CARDINAL; 361 BEGIN 362 LOOP 363 IF ((i>HIGH(Source)) OR (Source[i]=0C)) & ((j>HIGH(Pattern)) OR (Pattern[j]=0C)) THEN 364 RETURN TRUE; 365 ELSIF ((j > HIGH(Pattern)) OR (Pattern[j] = 0C)) THEN 366 RETURN FALSE; 367 ELSIF (Pattern[j]='*') THEN 368 k :=i; 369 IF ((j=HIGH(Pattern)) OR (Pattern[j+1]=0C)) THEN 370 IF p<=HIGH(pos) THEN 371 pos[p].Pos := i; 372 WHILE (k#HIGH(Source)) & (Source[k+1]#0C) DO 373 INC(k); 374 END; (*WHILE*) 375 pos[p].Len := 1+k-i; 376 END; (*IF*) 377 RETURN TRUE; 378 ELSE 379 LOOP 380 matched := Rmatch(k,j+1,p+1); 381 IF matched OR (k > HIGH(Source)) OR (Source[k] = 0C) THEN 382 IF matched AND (p<=HIGH(pos)) THEN 383 pos[p].Pos := i; 384 pos[p].Len := k-i; 385 END; (*IF*) 386 RETURN matched; 387 END; 388 INC(k); 389 END; (*LOOP*) 390 END; (*IF*) 391 ELSIF (Pattern[j] # '?') & (CAP(Pattern[j]) # CAP(Source[i])) THEN 392 RETURN FALSE; 393 ELSE 394 IF Pattern[j]='?' THEN 395 pos[p].Pos:=i; 396 pos[p].Len:=1; 397 INC(p); 398 END; (*IF*) 399 INC(i); 400 INC(j); 401 END; (*IF*) 402 END; (*LOOP*) 403 END Rmatch; 404 405 BEGIN 406 IF Pattern[0]=0C THEN 407 RETURN TRUE; 408 ELSE 409 RETURN Rmatch(0,0,0); 410 END; 411 END FindSubStr; 412 413 PROCEDURE StrToC(S:ARRAY OF CHAR;VAR D:ARRAY OF CHAR):BOOLEAN; 414 VAR 415 n : CARDINAL; 416 c : CHAR; 417 BEGIN 418 n := 0; 419 LOOP 420 IF n > HIGH(D) THEN 421 RETURN FALSE; 422 END; (*IF*) 423 IF n > HIGH(S) THEN 424 c := 0C; 425 ELSE 426 c := S[n]; 427 END; (*IF*) 428 D[n] := c; 429 IF c = 0C THEN 430 RETURN TRUE; 431 END; (*IF*) 432 INC(n); 433 END; (*LOOP*) 434 END StrToC; 435 436 PROCEDURE StrToPas(S:ARRAY OF CHAR;VAR D:ARRAY OF CHAR):BOOLEAN; 437 VAR 438 n : CARDINAL; 439 c : CHAR; 440 BEGIN 441 n := 1; 442 LOOP 443 IF n > HIGH(D) THEN 444 D[0] := 0C; 445 RETURN FALSE; 446 END; (*IF*) 447 IF n > SIZE(S) THEN 448 c := 0C; 449 ELSE 450 c := S[n-1]; 451 END; (*IF*) 452 IF c = 0C THEN 453 D[0] := CHAR(n-1); 454 RETURN TRUE; 455 END; (*IF*) 456 D[n] := c; 457 INC(n); 458 END; (*LOOP*) 459 END StrToPas; 460 461 END WinStr. 160 errors