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