development/compilers/freepascal/rtl/inc/sstrings.inc

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by the Free Pascal development team
   5
   6     See the file COPYING.FPC, included in this distribution,
   7     for details about the copyright.
   8
   9     This program is distributed in the hope that it will be useful,
  10     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12
  13  **********************************************************************}
  14
  15 {****************************************************************************
  16                     subroutines for string handling
  17 ****************************************************************************}
  18
  19 {$I real2str.inc}
  20
  21 function copy(const s : shortstring;index : StrLenInt;count : StrLenInt): shortstring;
  22 begin
  23   if count<0 then
  24    count:=0;
  25   if index>1 then
  26    dec(index)
  27   else
  28    index:=0;
  29   if index>length(s) then
  30    count:=0
  31   else
  32    if count>length(s)-index then
  33     count:=length(s)-index;
  34   Copy[0]:=chr(Count);
  35   Move(s[Index+1],Copy[1],Count);
  36 end;
  37
  38
  39 procedure delete(var s : shortstring;index : StrLenInt;count : StrLenInt);
  40 begin
  41   if index<=0 then
  42    begin
  43      inc(count,index-1);
  44      index:=1;
  45    end;
  46   if (Index<=Length(s)) and (Count>0) then
  47    begin
  48      if Count>length(s)-Index then
  49       Count:=length(s)-Index+1;
  50      s[0]:=Chr(length(s)-Count);
  51      if Index<=Length(s) then
  52       Move(s[Index+Count],s[Index],Length(s)-Index+1);
  53    end;
  54 end;
  55
  56
  57 procedure insert(const source : shortstring;var s : shortstring;index : StrLenInt);
  58 var
  59   cut,srclen,indexlen : longint;
  60 begin
  61   if index<1 then
  62    index:=1;
  63   if index>length(s) then
  64    index:=length(s)+1;
  65   indexlen:=Length(s)-Index+1;
  66   srclen:=length(Source);
  67   if length(source)+length(s)>=sizeof(s) then
  68    begin
  69      cut:=length(source)+length(s)-sizeof(s)+1;
  70      if cut>indexlen then
  71       begin
  72         dec(srclen,cut-indexlen);
  73         indexlen:=0;
  74       end
  75      else
  76       dec(indexlen,cut);
  77    end;
  78   move(s[Index],s[Index+srclen],indexlen);
  79   move(Source[1],s[Index],srclen);
  80   s[0]:=chr(index+srclen+indexlen-1);
  81 end;
  82
  83
  84 procedure insert(source : Char;var s : shortstring;index : StrLenInt);
  85 var
  86   indexlen : longint;
  87 begin
  88   if index<1 then
  89    index:=1;
  90   if index>length(s) then
  91    index:=length(s)+1;
  92   indexlen:=Length(s)-Index+1;
  93   if (length(s)+1=sizeof(s)) and (indexlen>0) then
  94    dec(indexlen);
  95   move(s[Index],s[Index+1],indexlen);
  96   s[Index]:=Source;
  97   s[0]:=chr(index+indexlen);
  98 end;
  99
 100
 101 function pos(const substr : shortstring;const s : shortstring):StrLenInt;
 102 var
 103   i,j : StrLenInt;
 104   e   : boolean;
 105 begin
 106   i := 0;
 107   j := 0;
 108   e:=(length(SubStr)>0);
 109   while e and (i<=Length(s)-Length(SubStr)) do
 110    begin
 111      inc(i);
 112      if (SubStr[1]=s[i]) and (Substr=Copy(s,i,Length(SubStr))) then
 113       begin
 114         j:=i;
 115         e:=false;
 116       end;
 117    end;
 118   Pos:=j;
 119 end;
 120
 121
 122 {Faster when looking for a single char...}
 123 function pos(c:char;const s:shortstring):StrLenInt;
 124 var
 125   i : StrLenInt;
 126 begin
 127   for i:=1 to length(s) do
 128    if s[i]=c then
 129     begin
 130       pos:=i;
 131       exit;
 132     end;
 133   pos:=0;
 134 end;
 135
 136
 137 procedure SetLength(var s:shortstring;len:StrLenInt);
 138 begin
 139   if Len>255 then
 140    Len:=255;
 141   s[0]:=chr(len);
 142 end;
 143
 144
 145 function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
 146 begin
 147   if (index=1) and (Count>0) then
 148    Copy:=c
 149   else
 150    Copy:='';
 151 end;
 152
 153
 154 function pos(const substr : shortstring;c:char): StrLenInt;
 155 begin
 156   if (length(substr)=1) and (substr[1]=c) then
 157    Pos:=1
 158   else
 159    Pos:=0;
 160 end;
 161
 162
 163 { removed must be internal to be accepted in const expr !! PM
 164 function length(c:char):StrLenInt;
 165 begin
 166   Length:=1;
 167 end;
 168 }
 169
 170 {$ifdef IBM_CHAR_SET}
 171 const
 172   UpCaseTbl : shortstring[7]=#154#142#153#144#128#143#165;
 173   LoCaseTbl : shortstring[7]=#129#132#148#130#135#134#164;
 174 {$endif}
 175
 176 function upcase(c : char) : char;
 177 {$IFDEF IBM_CHAR_SET}
 178 var
 179   i : longint;
 180 {$ENDIF}
 181 begin
 182   if (c in ['a'..'z']) then
 183     upcase:=char(byte(c)-32)
 184   else
 185 {$IFDEF IBM_CHAR_SET}
 186     begin
 187       i:=Pos(c,LoCaseTbl);
 188       if i>0 then
 189        upcase:=UpCaseTbl[i]
 190       else
 191        upcase:=c;
 192     end;
 193 {$ELSE}
 194    upcase:=c;
 195 {$ENDIF}
 196 end;
 197
 198
 199 function upcase(const s : shortstring) : shortstring;
 200 var
 201   i : longint;
 202 begin
 203   upcase[0]:=s[0];
 204   for i := 1 to length (s) do
 205     upcase[i] := upcase (s[i]);
 206 end;
 207
 208
 209 {$ifndef RTLLITE}
 210
 211 function lowercase(c : char) : char;
 212 {$IFDEF IBM_CHAR_SET}
 213 var
 214   i : longint;
 215 {$ENDIF}
 216 begin
 217   if (c in ['A'..'Z']) then
 218    lowercase:=char(byte(c)+32)
 219   else
 220 {$IFDEF IBM_CHAR_SET}
 221    begin
 222      i:=Pos(c,UpCaseTbl);
 223      if i>0 then
 224       lowercase:=LoCaseTbl[i]
 225      else
 226       lowercase:=c;
 227    end;
 228  {$ELSE}
 229    lowercase:=c;
 230  {$ENDIF}
 231 end;
 232
 233
 234 function lowercase(const s : shortstring) : shortstring;
 235 var
 236   i : longint;
 237 begin
 238   lowercase [0]:=s[0];
 239   for i:=1 to length(s) do
 240    lowercase[i]:=lowercase (s[i]);
 241 end;
 242
 243
 244 function hexstr(val : longint;cnt : byte) : shortstring;
 245 const
 246   HexTbl : array[0..15] of char='0123456789ABCDEF';
 247 var
 248   i : longint;
 249 begin
 250   hexstr[0]:=char(cnt);
 251   for i:=cnt downto 1 do
 252    begin
 253      hexstr[i]:=hextbl[val and $f];
 254      val:=val shr 4;
 255    end;
 256 end;
 257
 258
 259 function binstr(val : longint;cnt : byte) : shortstring;
 260 var
 261   i : longint;
 262 begin
 263   binstr[0]:=char(cnt);
 264   for i:=cnt downto 1 do
 265    begin
 266      binstr[i]:=char(48+val and 1);
 267      val:=val shr 1;
 268    end;
 269 end;
 270
 271 {$endif RTLLITE}
 272
 273
 274 function space (b : byte): shortstring;
 275 begin
 276   space[0] := chr(b);
 277   FillChar (Space[1],b,' ');
 278 end;
 279
 280
 281 {*****************************************************************************
 282                               Str() Helpers
 283 *****************************************************************************}
 284
 285 procedure ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT'];
 286 begin
 287   str_real(len,fr,d,treal_type(rt),s);
 288 end;
 289
 290
 291 procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT'];
 292 begin
 293   int_str(v,s);
 294   if length(s)<len then
 295     s:=space(len-length(s))+s;
 296 end;
 297
 298
 299 procedure int_str_cardinal(v : cardinal;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_CARDINAL'];
 300 begin
 301   int_str(v,s);
 302   if length(s)<len then
 303     s:=space(len-length(s))+s;
 304 end;
 305
 306
 307 {*****************************************************************************
 308                            Val() Functions
 309 *****************************************************************************}
 310
 311 Function InitVal(const s:shortstring;var negativ:boolean;var base:byte):ValSInt;
 312 var
 313   Code : Longint;
 314 begin
 315 {Skip Spaces and Tab}
 316   code:=1;
 317   while (code<=length(s)) and (s[code] in [' ',#9]) do
 318    inc(code);
 319 {Sign}
 320   negativ:=false;
 321   case s[code] of
 322    '-' : begin
 323            negativ:=true;
 324            inc(code);
 325          end;
 326    '+' : inc(code);
 327   end;
 328 {Base}
 329   base:=10;
 330   if code<=length(s) then
 331    begin
 332      case s[code] of
 333       '$' : begin
 334               base:=16;
 335               repeat
 336                 inc(code);
 337               until (code>=length(s)) or (s[code]<>'0');
 338             end;
 339       '%' : begin
 340               base:=2;
 341               inc(code);
 342             end;
 343      end;
 344   end;
 345   InitVal:=code;
 346 end;
 347
 348
 349 Function ValSignedInt(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR'];
 350 var
 351   u, temp, prev: ValUInt;
 352   base : byte;
 353   negative : boolean;
 354 begin
 355   ValSignedInt := 0;
 356   Temp:=0;
 357   Code:=InitVal(s,negative,base);
 358   if Code>length(s) then
 359    exit;
 360   while Code<=Length(s) do
 361    begin
 362      case s[Code] of
 363        '0'..'9' : u:=Ord(S[Code])-Ord('0');
 364        'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10);
 365        'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10);
 366      else
 367       u:=16;
 368      end;
 369      Prev := Temp;
 370      Temp := Temp*ValUInt(base);
 371      If (u >= base) or
 372         ((base = 10) and
 373          (MaxSIntValue-temp+ord(negative) < u)) or
 374         ((base <> 10) and
 375          (ValUInt(MaxUIntValue-Temp) < u)) or
 376         (prev > ValUInt(MaxUIntValue) div ValUInt(Base)) Then
 377        Begin
 378          ValSignedInt := 0;
 379          Exit
 380        End;
 381      Temp:=Temp+u;
 382      inc(code);
 383    end;
 384   code := 0;
 385   ValSignedInt := ValSInt(Temp);
 386   If Negative Then
 387     ValSignedInt := -ValSignedInt;
 388   If Not(Negative) and (base <> 10) Then
 389    {sign extend the result to allow proper range checking}
 390     Case DestSize of
 391       1: If (ValSignedInt > High(ShortInt)) and (ValSignedInt <= High(Byte)) Then
 392            ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Byte));
 393       2: If (ValSignedInt > High(Integer)) and (ValSignedInt <= High(Word)) Then
 394            ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Word));
 395 {     Uncomment the folling once full 64bit support is in place
 396       4: If (ValSignedInt > High(Longint)) and (ValSignedInt <= High(Cardinal)) Then
 397            ValSignedInt := ValSignedInt or (MaxUIntValue xor High(Cardinal));}
 398     End;
 399 end;
 400
 401
 402 Function ValUnsignedInt(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR'];
 403 var
 404   u, prev: ValUInt;
 405   base : byte;
 406   negative : boolean;
 407 begin
 408   ValUnSignedInt:=0;
 409   Code:=InitVal(s,negative,base);
 410   If Negative or (Code>length(s)) Then
 411     Exit;
 412   while Code<=Length(s) do
 413    begin
 414      case s[Code] of
 415        '0'..'9' : u:=Ord(S[Code])-Ord('0');
 416        'A'..'F' : u:=Ord(S[Code])-(Ord('A')-10);
 417        'a'..'f' : u:=Ord(S[Code])-(Ord('a')-10);
 418      else
 419       u:=16;
 420      end;
 421      prev := ValUnsignedInt;
 422      If (u>=base) or
 423         (ValUInt(MaxUIntValue-u) div ValUInt(Base)<prev) then
 424       begin
 425         ValUnsignedInt:=0;
 426         exit;
 427       end;
 428      ValUnsignedInt:=ValUnsignedInt*ValUInt(base) + u;
 429      inc(code);
 430    end;
 431   code := 0;
 432 end;
 433
 434
 435 Function ValFloat(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR'];
 436 var
 437   hd,
 438   esign,sign : valreal;
 439   exponent,i : longint;
 440   flags      : byte;
 441 begin
 442   ValFloat:=0.0;
 443   code:=1;
 444   exponent:=0;
 445   esign:=1;
 446   flags:=0;
 447   sign:=1;
 448   while (code<=length(s)) and (s[code] in [' ',#9]) do
 449    inc(code);
 450   case s[code] of
 451    '+' : inc(code);
 452    '-' : begin
 453            sign:=-1;
 454            inc(code);
 455          end;
 456   end;
 457   while (Code<=Length(s)) and (s[code] in ['0'..'9']) do
 458    begin
 459    { Read integer part }
 460       flags:=flags or 1;
 461       valfloat:=valfloat*10+(ord(s[code])-ord('0'));
 462       inc(code);
 463    end;
 464 { Decimal ? }
 465   if (s[code]='.') and (length(s)>=code) then
 466    begin
 467       hd:=1.0;
 468       inc(code);
 469       while (s[code] in ['0'..'9']) and (length(s)>=code) do
 470         begin
 471            { Read fractional part. }
 472            flags:=flags or 2;
 473            valfloat:=valfloat*10+(ord(s[code])-ord('0'));
 474            hd:=hd*10.0;
 475            inc(code);
 476         end;
 477       valfloat:=valfloat/hd;
 478    end;
 479  { Again, read integer and fractional part}
 480   if flags=0 then
 481    begin
 482       valfloat:=0.0;
 483       exit;
 484    end;
 485  { Exponent ? }
 486   if (upcase(s[code])='E') and (length(s)>=code) then
 487    begin
 488       inc(code);
 489       if s[code]='+' then
 490         inc(code)
 491       else
 492         if s[code]='-' then
 493          begin
 494            esign:=-1;
 495            inc(code);
 496          end;
 497       if not(s[code] in ['0'..'9']) or (length(s)<code) then
 498         begin
 499            valfloat:=0.0;
 500            exit;
 501         end;
 502       while (s[code] in ['0'..'9']) and (length(s)>=code) do
 503         begin
 504            exponent:=exponent*10;
 505            exponent:=exponent+ord(s[code])-ord('0');
 506            inc(code);
 507         end;
 508    end;
 509 { Calculate Exponent }
 510 {
 511   if esign>0 then
 512     for i:=1 to exponent do
 513       valfloat:=valfloat*10
 514     else
 515       for i:=1 to exponent do
 516         valfloat:=valfloat/10; }
 517   hd:=1.0;
 518   for i:=1 to exponent do
 519     hd:=hd*10.0;
 520   if esign>0 then
 521     valfloat:=valfloat*hd
 522   else
 523     valfloat:=valfloat/hd;
 524 { Not all characters are read ? }
 525   if length(s)>=code then
 526    begin
 527      valfloat:=0.0;
 528      exit;
 529    end;
 530 { evaluate sign }
 531   valfloat:=valfloat*sign;
 532 { success ! }
 533   code:=0;
 534 end;
 535
 536
 537 {$ifdef SUPPORT_FIXED}
 538 Function ValFixed(const s : shortstring;var code : ValSInt): Fixed; [public, alias:'FPC_VAL_FIXED_SHORTSTR'];
 539 begin
 540   ValFixed := Fixed(ValFloat(s,code));
 541 end;
 542 {$endif SUPPORT_FIXED}
 543
 544
 545 Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
 546 begin
 547   Move (Buf[0],S[1],Len);
 548   S[0]:=chr(len);
 549 end;
 550
 551 {
 552   $Log$
 553   Revision 1.1  2002/02/19 08:25:28  sasu
 554   Initial revision
 555
 556   Revision 1.1.2.4  2000/12/09 20:49:34  florian
 557     * val for dword and qword didn't handle the max values
 558       correctly
 559     * val for qword works again
 560     + val with int64/qword and ansistring implemented
 561
 562   Revision 1.1.2.3  2000/11/23 11:40:34  jonas
 563     * fix for web bug 1265 by Peter
 564
 565   Revision 1.1.2.2  2000/11/17 16:56:42  jonas
 566     * fixed bug for val when processing -2147483648 and low(int64)
 567
 568   Revision 1.1.2.1  2000/07/28 12:19:21  jonas
 569     * fixed web bug1069
 570     * fixed similar (and other) problems in val() for int64 and qword
 571
 572   Revision 1.1  2000/07/13 06:30:48  michael
 573   + Initial import
 574
 575   Revision 1.35  2000/04/06 11:51:47  pierre
 576    * fix for extended constants
 577
 578   Revision 1.34  2000/02/09 16:59:31  peter
 579     * truncated log
 580
 581   Revision 1.33  2000/01/07 16:41:36  daniel
 582     * copyright 2000
 583
 584   Revision 1.32  2000/01/07 16:32:25  daniel
 585     * copyright 2000 added
 586
 587   Revision 1.31  1999/12/11 19:07:44  jonas
 588     * avoid unwanted type conversion from cardinal to longint in val for
 589       signed and unsigned 32bit int
 590
 591   Revision 1.30  1999/11/06 14:35:39  peter
 592     * truncated log
 593
 594 }