code.delx.au - gnu-emacs/blob - test/manual/etags/pas-src/common.pas

   1 #include "common.i"
   2 #include "common.h"
   3
   4 type
   5   NSPoolP = ^NSPoolRec;
   6   NSPoolRec = record
   7     Data: NameStringPointer;
   8     Next: NSPoolP;
   9   end;
  10
  11 var
  12   GlobalNSPool: record
  13     Avail, Empty: NSPoolP;
  14   end;
  15
  16 var
  17   AvailString : TextString;
  18   NameList : BinNodePointer;
  19   AvailNameList : BinNodePointer;
  20
  21
  22
  23 (*------------------------------------------------------------------*)
  24 (*                    InitializeStringPackage                       *)
  25 (*------------------------------------------------------------------*)
  26 procedure InitializeStringPackage;
  27 begin (* InitializeStringPackage *)
  28   AvailString := nil;
  29 end; (* InitializeStringPackage *)
  30
  31 (*------------------------------------------------------------------*)
  32 (*                    newtextstring                                 *)
  33 (*------------------------------------------------------------------*)
  34 function newtextstring; (*: TextString;*)
  35 var
  36   Temp : TextString;
  37 begin (* newtextstring *)
  38   if AvailString = nil then
  39     new (Temp)
  40   else begin
  41     Temp := AvailString;
  42     AvailString := Temp^.Next;
  43   end;
  44   Temp^.String.Length := 0;
  45   Temp^.Next := nil;
  46   newtextstring := Temp;
  47 end; (* newtextstring *)
  48
  49 (*------------------------------------------------------------------*)
  50 (*                    disposetextstring                             *)
  51 (*------------------------------------------------------------------*)
  52 procedure disposetextstring;(*(
  53   var S : TextString);*)
  54 var
  55   Temp : TextString;
  56   Temp2 : TextString;
  57 begin (* disposetextstring *)
  58   if S <> nil then begin
  59     Temp := S;
  60 (*
  61     while Temp^.Next <> nil do
  62       Temp := Temp^.Next;
  63     Temp^.Next := AvailString;
  64     AvailString := S;
  65 *)
  66     S := nil;
  67     repeat
  68       Temp2 := Temp^.Next;
  69       dispose(Temp);
  70       Temp := Temp2;
  71     until Temp = nil;
  72    end;
  73 end; (* disposetextstring *)
  74
  75 (*------------------------------------------------------------------*)
  76 (*                    ConcatT                                       *)
  77 (*------------------------------------------------------------------*)
  78 function ConcatT;(*(
  79   ToString : TextString;
  80   S        : TextString) : TextString;*)
  81 var
  82   Index : integer;
  83 begin (* ConcatT *)
  84   ConcatT := ToString;
  85   if ToString = nil then
  86     writeln (output, 'Error in ConcatT, ToString is nil')
  87   else
  88     if S = nil then
  89       writeln (output, 'Error in ConcatT, S is nil')
  90     else
  91       if S^.Next <> nil then
  92         writeln (output,
  93           'Error in ConcatT, S contains several linked TextStrings')
  94       else begin
  95         while ToString^.Next <> nil do
  96           ToString := ToString^.Next;
  97         if ToString^.String.Length+S^.String.Length > NameStringLength then begin
  98           ToString^.Next := newtextstring;
  99           ToString := ToString^.Next;
 100         end;
 101         with ToString^, String do begin
 102           for Index := 1 to S^.String.Length do
 103             Value[Length+Index] := S^.String.Value[Index];
 104           Length := Length+S^.String.Length;
 105         end;
 106       end;
 107 end; (* ConcatT *)
 108
 109 (*------------------------------------------------------------------*)
 110 (*                    AppendTextString                              *)
 111 (*------------------------------------------------------------------*)
 112 function AppendTextString;(*(
 113   ToString : TextString;
 114   S        : TextString) : TextString;*)
 115 begin (* AppendTextString *)
 116   AppendTextString := ToString;
 117   if ToString = nil then
 118     writeln (output, 'Error in AppendTextString, ToString is nil')
 119   else
 120     if S = nil then
 121       writeln (output, 'Error in AppendTextString, S is nil')
 122     else begin
 123       while ToString^.Next <> nil do
 124         ToString := ToString^.Next;
 125       ToString^.Next := S;
 126     end;
 127 end; (* AppendTextString *)
 128
 129 (*------------------------------------------------------------------*)
 130 (*                    CopyTextString                                *)
 131 (*------------------------------------------------------------------*)
 132 function CopyTextString;(*(
 133   S : TextString
 134   ) : TextString;*)
 135 var
 136   Temp : TextString;
 137 begin   (* CopyTextString *)
 138   if S <> nil then begin
 139     Temp := newtextstring;
 140     Temp^.String := S^.String;
 141     Temp^.Next := CopyTextString(S^.Next);
 142     CopyTextString := Temp;
 143   end
 144   else
 145     CopyTextString := nil;
 146 end;    (* CopyTextString *)
 147
 148 (*------------------------------------------------------------------*)
 149 (*                    CONVERT_CHARSTRING_TO_VALUE                   *)
 150 (*------------------------------------------------------------------*)
 151 procedure CONVERT_CHARSTRING_TO_VALUE;(*(
 152       S : NameString;
 153   var V : NameString);*)
 154 var
 155   Pos : integer;
 156   VPos : integer;
 157   Ch : char;
 158 begin (* CONVERT_CHARSTRING_TO_VALUE *)
 159   VPos := 0;
 160   for Pos := 2 to S.Length - 1 do begin
 161     Ch := S.Value[Pos];
 162     if not ((Ch = '''') and (Pos > 2) and (S.Value[Pos - 1] = '''')) then
 163       VPos := VPos + 1;
 164     V.Value[VPos] := Ch;
 165   end;
 166   V.Length := VPos;
 167 end; (* CONVERT_CHARSTRING_TO_VALUE *)
 168
 169 (*------------------------------------------------------------------*)
 170 (*                    append_string                                 *)
 171 (*------------------------------------------------------------------*)
 172 procedure append_string;(*(
 173   var Txt    : TextString;
 174   var String : NameString);*)
 175 var
 176   Temp : TextString;
 177 begin (* append_string *)
 178   Temp := newtextstring;
 179   Temp^.String := String;
 180   if Txt = nil then
 181     Txt := Temp
 182   else
 183     Txt := AppendTextString(Txt, Temp);
 184 end; (* append_string *)
 185
 186 function To_Upper;(*(ch:char) : char;*)
 187 begin
 188   if ch in ['a'..'z'] then
 189     To_Upper := chr(ord(ch) + ord('A')-ord('a'))
 190   else
 191     To_Upper := ch;
 192 end;
 193
 194 function To_Lower;(*(ch:char) : char;*)
 195 begin
 196   if ch in ['A'..'Z'] then
 197     To_Lower := chr(ord(ch) - ord('A') + ord('a'))
 198   else
 199     To_Lower := ch;
 200 end;
 201
 202 (*----------------------------------------------------------------------*)
 203 (*              Operations on NameString                                *)
 204 (*----------------------------------------------------------------------*)
 205
 206 (*------------------------------------------------------------------*)
 207 (*                    EmptyNmStr                                    *)
 208 (*------------------------------------------------------------------*)
 209 function EmptyNmStr(* : NameString*);
 210 var
 211   Nm : NameString;
 212 begin   (* EmptyNmStr *)
 213   Nm.Length := 0;
 214   EmptyNmStr := Nm;
 215 end;    (* EmptyNmStr *)
 216
 217
 218 (* returns a namestring containing one character, the inparameter Ch *)
 219 function chartonmstr; (*(
 220   Ch : Char) : NameString; *)
 221 var
 222   String : NameString;
 223 begin
 224   String.Value[1] := Ch;
 225   String.Length := 1;
 226   chartonmstr := String;
 227 end;
 228
 229 (* returns a namestring containing the inparameter Str in lowercase letters *)
 230 function LowerCaseNmStr; (*(
 231   Str : NameString) : NameString; *)
 232 var
 233   i : integer;
 234 begin (* LowerCaseNmStr *)
 235   with Str do
 236     for i := 1 to Length do
 237       Value[i] := To_Lower(Value[i]);
 238   LowerCaseNmStr := Str;
 239 end; (* LowerCaseNmStr *)
 240
 241 (* returns a namestring containing inparameter S1 concatenated with inpar. S2 *)
 242 function concatenatenamestrings; (*(
 243   S1 : NameString;
 244   S2 : NameString) : NameString; *)
 245 var
 246   Temp : NameString;
 247   Pos : integer;
 248 begin (* concatenatenamestrings *)
 249   Temp := S1;
 250   with Temp do begin
 251     Pos := 0;
 252     while Pos < S2.Length do begin
 253       Pos := Pos + 1;
 254       if Length < NameStringLength then begin
 255         Length := Length + 1;
 256         Value[Length] := S2.Value[Pos];
 257       end;
 258     end; (* while *)
 259   end; (* with *)
 260   concatenatenamestrings := Temp;
 261 end; (* concatenatenamestrings *)
 262
 263 procedure writenamestring;(*(
 264   var TextFile : text;
 265   var Name     : NameString);*)
 266 var
 267   Pos : integer;
 268 begin
 269   with Name do
 270     for Pos := 1 to Length do
 271       write(TextFile, Value[Pos]);
 272 end;
 273
 274 (*------------------------------------------------------------------*)
 275 (*                    IsControlChar                                 *)
 276 (*------------------------------------------------------------------*)
 277 function IsControlChar; (*(
 278   Ch : char) : boolean; *)
 279 begin (* IsControlChar *)
 280   IsControlChar := ord(Ch) in [0..32, 127];
 281 end; (* IsControlChar *)
 282
 283 function namestringequal;(*(var Name1,Name2 : NameString) : Boolean;*)
 284 var i : Integer;
 285     equal : Boolean;
 286 begin
 287   if Name1.Length = Name2.Length then begin
 288     equal := true;
 289     i := 1;
 290     while (i <= Name1.Length) and equal do begin
 291        equal := To_Upper(Name1.Value[i]) = To_Upper(Name2.Value[i]);
 292        i := i + 1;
 293     end;
 294     namestringequal := equal;
 295   end
 296   else
 297     namestringequal := false;
 298 end;
 299
 300 (* Character strings are case sensitive *)
 301
 302 function NameStringLess;(*(var Name1,Name2 : NameString) : Boolean;*)
 303 var i, minlength : Integer;
 304     equal : Boolean;
 305     C1, C2 : char;
 306     Charstring : boolean;
 307 begin
 308   C1 := ' ';
 309   C2 := ' ';
 310   if Name1.Length < Name2.Length then
 311     minlength := Name1.Length
 312   else
 313     minlength := Name2.Length;
 314   if MinLength > 0 then
 315     Charstring := (Name1.Value[1] = '''') or (Name2.Value[1] = '''')
 316   else
 317     Charstring := false;
 318 (*   Charstring := true; force case sensitive *)
 319   i := 1;
 320   equal := true;
 321   if i <= minlength then
 322     while (i <= minlength) and equal do begin
 323       if Charstring then begin
 324         C1 := Name1.Value[i];
 325         C2 := Name2.Value[i];
 326       end
 327       else begin
 328         C1 := To_Upper(Name1.Value[i]);
 329         C2 := To_Upper(Name2.Value[i]);
 330       end;
 331       equal := C1 = C2;
 332       i := i + 1;
 333     end; (* while *)
 334   if equal then
 335     NameStringLess := Name1.Length < Name2.Length
 336   else
 337     NameStringLess := C1 < C2;
 338 end;
 339
 340 (*------------------------------------------------------------------*)
 341 (*                    IsControlCharName                             *)
 342 (*------------------------------------------------------------------*)
 343 function IsControlCharName(
 344   Str : NameString;
 345   Pos : integer) : boolean;
 346 begin (* IsControlCharName *)
 347   with Str do begin
 348     if Pos <= Length then
 349       IsControlCharName := IsControlChar(Value[Pos])
 350     else
 351       IsControlCharName := false;
 352   end;
 353 end; (* IsControlCharName *)
 354
 355 (*------------------------------------------------------------------*)
 356 (*                    SubString                                     *)
 357 (*------------------------------------------------------------------*)
 358 function SubString; (*(
 359   Str : NameString;
 360   Start : integer;
 361   Len : integer) : NameString; *)
 362 var
 363   i : integer;
 364 begin (* SubString *)
 365   with Str do begin
 366     if Len > 0 then
 367       for i := Start to Start + Len - 1 do
 368         Value[i- Start + 1] := Value[i]
 369     else if Len < 0 then
 370       Len := 0;
 371     Length := Len;
 372   end;
 373   SubString := Str;
 374 end; (* SubString *)
 375
 376 (*------------------------------------------------------------------*)
 377 (*                    SkipChars                                     *)
 378 (*------------------------------------------------------------------*)
 379 function SkipChars; (*(
 380   Str : NameString;
 381   Start : integer;
 382   Len : integer) : NameString; *)
 383 var
 384   i : integer;
 385 begin (* SkipChars *)
 386   with Str do begin
 387     for i := Start to Length - Len do
 388       Value[i] := Value[i + Len];
 389     Length := Length - Len;
 390   end;
 391   SkipChars := Str;
 392 end; (* SkipChars *)
 393
 394 (*------------------------------------------------------------------*)
 395 (*                    RemoveUnderlineControl                        *)
 396 (*------------------------------------------------------------------*)
 397 function RemoveUnderlineControl; (*(
 398       Str : NameString) : NameString; *)
 399 var
 400   Len : integer;
 401   i : integer;
 402   Start : integer;
 403 begin (* RemoveUnderlineControl *)
 404   with Str do begin
 405     i := 1;
 406     while i <= Length do begin
 407       if Value[i] = '_' then begin
 408         Len := 0;
 409         Start := i;
 410         while IsControlCharName(Str, i + 1 + Len) do
 411           Len := Len + 1;
 412         if Len > 0 then
 413           Str := SkipChars(Str, Start, Len + 1)
 414         else
 415           i := i + 1;
 416       end
 417       else
 418         i := i + 1;
 419     end; (* while *)
 420   end; (* with *)
 421   RemoveUnderlineControl := Str;
 422 end; (* RemoveUnderlineControl *)
 423
 424 (*------------------------------------------------------------------*)
 425 (*                    First100Chars                                 *)
 426 (*------------------------------------------------------------------*)
 427 procedure First100Chars; (*(
 428       Txt : TextString;
 429   var Str : NameString;
 430   var Truncated : boolean); *)
 431 var
 432   Len : integer;
 433   i : integer;
 434 begin (* First100Chars *)
 435   Str.Length := 0;
 436   if Txt <> nil then begin
 437     Str := Txt^.String;
 438     Txt := Txt^.Next;
 439   end;
 440   while (Txt <> nil) and (Str.Length < NameStringLength) do
 441     with Txt^, String do begin
 442       Str.Length := Str.Length + 1;
 443       Str.Value[Str.Length] := ' ';
 444       if Str.Length + Length <= NameStringLength then
 445         Len := Str.Length + Length
 446       else
 447         Len := NameStringLength;
 448       for i := Str.Length + 1 to Len do
 449         Str.Value[i] := Value[i - Str.Length];
 450       Str.Length := Len;
 451       Txt := Txt^.Next;
 452     end; (* while with *)
 453   Truncated := Txt <> nil;
 454 end; (* First100Chars *)
 455
 456
 457 (*------------------------------------------------------------------*)
 458 (*                    SkipSpaces                                    *)
 459 (*------------------------------------------------------------------*)
 460 (* changes I to contain the first index in Str (starting at I) that *)
 461 (* is not a space                                                   *)
 462 procedure SkipSpaces; (* (Str : NameString; var I : Integer);*)
 463 var Stop : boolean;
 464 begin   (* SkipSpaces *)
 465   Stop := false;
 466   while (I < Str.Length) and not Stop do
 467     if Str.Value[I] <> ' ' then
 468       Stop := true
 469     else
 470       I := I+1;
 471 end;    (* SkipSpaces *)
 472
 473
 474 (*------------------------------------------------------------------*)
 475 (*                    SkipBlanks                                    *)
 476 (*------------------------------------------------------------------*)
 477 function SkipBlanks; (*(
 478   TextLine: NameString) : NameString; *)
 479 var
 480   i : integer;
 481   j : integer;
 482   SpaceFound : boolean;
 483 begin (* SkipBlanks *)
 484   with TextLine do begin
 485     SpaceFound := true;
 486     i := 1;
 487     while SpaceFound and (i <= Length) do begin
 488       SpaceFound := (Value[i] in [' ', chr(9)]);
 489       if SpaceFound then
 490         i := i + 1;
 491     end; (* while *)
 492     i := i - 1;
 493     if i > 0 then
 494       for j := 1 to Length - i do
 495         if j <= Length - i then
 496           Value[j] := Value[j + i];
 497     Length := Length - i;
 498   end; (* with *)
 499   SkipBlanks := TextLine;
 500 end; (* SkipBlanks *)
 501
 502 (*------------------------------------------------------------------*)
 503 (*                    stripname                                     *)
 504 (*------------------------------------------------------------------*)
 505 function stripname; (* (
 506   TextLine: NameString) : NameString; *)
 507 var
 508   SpaceFound : boolean;
 509 begin (* stripname *)
 510   TextLine := SkipBlanks(TextLine);
 511   with TextLine do begin
 512     SpaceFound := true;
 513     while SpaceFound and (Length > 0) do begin
 514       SpaceFound := (Value[Length ] in [' ', chr(9)]);
 515       if SpaceFound then
 516         Length := Length - 1;
 517     end; (* while *)
 518   end; (* with *)
 519   stripname := TextLine;
 520 end; (* stripname *)
 521
 522 function Locate; (*(
 523  Str : NameString;
 524  Chars : SetOfChar) : integer; *)
 525 var
 526   Pos : integer;
 527   Found : boolean;
 528 begin (* Locate *)
 529   Found := false;
 530   Pos := 0;
 531   with Str do
 532     while not Found and (Pos < Length) do begin
 533       Pos := Pos + 1;
 534       Found := Value[Pos] in Chars;
 535     end;
 536   Locate := Pos;
 537 end; (* Locate *)
 538
 539
 540 (*------------------------------------------------------------------*)
 541 (*                    NameHasChar                                   *)
 542 (*------------------------------------------------------------------*)
 543 function NameHasChar; (* (TheName : NameString; TheChar : char) : boolean;*)
 544 var i : integer;
 545     found : boolean;
 546
 547 begin   (* NameHasChar *)
 548   found := false;
 549   i := 0;
 550   while not found and (i < TheName.Length) do begin
 551     i := i+1;
 552     found := TheName.Value[i] = TheChar;
 553   end;
 554   NameHasChar := found;
 555 end;    (* NameHasChar *)
 556
 557
 558 (*------------------------------------------------------------------*)
 559 (*                    integertonmstr                                *)
 560 (*------------------------------------------------------------------*)
 561 function integertonmstr; (* (TheInteger : integer) : NameString; *)
 562 var Nm : NameString;
 563     Index,
 564     Size,
 565     TempNumber : integer;
 566 begin   (* integertonmstr *)
 567   Size := 1;
 568   TempNumber := TheInteger;
 569   while TempNumber div 10 > 0 do begin
 570     Size := Size + 1;
 571     TempNumber := TempNumber div 10;
 572   end;
 573   Nm.Length := Size;
 574   TempNumber := TheInteger;
 575   for Index := Size downto 1 do begin
 576     Nm.Value[Index] := chr(TempNumber mod 10 + ord('0'));
 577     TempNumber := TempNumber div 10;
 578   end;
 579   integertonmstr := Nm;
 580 end;    (* integertonmstr *)
 581
 582 (*------------------------------------------------------------------*)
 583 (*                    NmStrToInteger                                *)
 584 (*------------------------------------------------------------------*)
 585 function NmStrToInteger; (* (Str : NameString) : integer; *)
 586 var
 587   Index : integer;
 588   Numb : integer;
 589   Max : integer;
 590 begin   (* NmStrToInteger *)
 591  Max := (maxint div 10) - 10;
 592  Numb := 0;
 593   for Index := 1 to Str.Length do begin
 594     if (Numb <= Max) and (Str.Value[Index] in ['0'..'9']) then
 595       Numb := 10 * Numb + ord(Str.Value[Index]) - ord('0');
 596   end;
 597   NmStrToInteger := Numb;
 598 end;    (* NmStrToInteger *)
 599
 600 function AddNullToNmStr; (*(
 601   Nm : NameString) : NameString; *)
 602 begin (* AddNullToNmStr *)
 603   with Nm do
 604     if Length < NameStringLength then
 605       Value[Length + 1] := chr(0)
 606     else
 607       Value[Length] := chr(0);
 608   AddNullToNmStr := Nm;
 609 end; (* AddNullToNmStr *)
 610
 611 function ValToNmStr; (*(
 612   Nm : NameString) : NameString; *)
 613 begin (* ValToNmStr *)
 614   with Nm do begin
 615     length := 0;
 616     while value[length + 1] <> chr(0) do
 617       length := length + 1;
 618   end;
 619   ValToNmStr := Nm;
 620 end; (* ValToNmStr *)
 621
 622 (*------------------------------------------------------------------*)
 623 (*                    ChangeFileType                                *)
 624 (*------------------------------------------------------------------*)
 625 function ChangeFileType; (*(FileName : NameString;
 626   NewType : NameString) : NameString;*)
 627 var
 628   Pos : integer;
 629   Found : boolean;
 630 begin (* ChangeFileType *)
 631   with Filename do begin
 632     Pos := FileName.Length;
 633     Found := false;
 634     while not Found and (Pos > 0) do begin
 635       Found := Value[Pos] = '.';
 636       Pos := Pos - 1;
 637     end;
 638     if Found then
 639       Length := Pos;
 640   end; (* with *)
 641   ChangeFileType := concatenatenamestrings(FileName, NewType);
 642 end; (* ChangeFileType*)
 643
 644 (*------------------------------------------------------------------*)
 645 (*                    StripPath                                     *)
 646 (*------------------------------------------------------------------*)
 647 function StripPath; (*(
 648       Str : NameString) : NameString; *)
 649 var
 650   i : integer;
 651   Len : integer;
 652   Found : boolean;
 653 begin (* StripPath *)
 654   with Str do begin
 655     i := Length;
 656     Found := false;
 657     while not Found and (i > 0) do begin
 658       Found := Value[i] in  ['/', '\'];
 659       if not Found  then
 660         i := i - 1;
 661     end; (* while *)
 662     if Found then begin
 663       Len := Length - i + 1;
 664       if i < Length then begin
 665         i := i + 1;
 666         Len := Len - 1;
 667       end;
 668       StripPath := SubString(Str, i, Len);
 669     end
 670     else
 671       StripPath := Str;
 672   end; (* with *)
 673 end; (* StripPath *)
 674
 675 function ReprOfChar; (*( ch : char) : NameString;*)
 676 var
 677   Repr : NameString;
 678 begin
 679   if (ch >= ' ') and (ch <= '~') then
 680     Repr := chartonmstr(ch)
 681   else
 682     Repr := concatenatenamestrings(concatenatenamestrings(chartonmstr('<'),
 683               integertonmstr(ord(ch))), chartonmstr('>'));
 684   ReprOfChar := Repr;
 685 end; (* ReprOfChar *)
 686
 687 (*------------------------------------------------------------------*)
 688 (*                    ExtractCommentInfo                            *)
 689 (*------------------------------------------------------------------*)
 690 (* check if Comment contains graphic reference or include directive *)
 691 (* /*#<graphref>*/ or /*#<include-dir>*/                            *)
 692 (*    <graphref>    =G pagename xcoord ycoord                       *)
 693 (*                   T pagename xcoord ycoord                       *)
 694 (*                   M diagramtype diagramname pagename xcoord ycoord *)
 695 (*                   D databankname                                 *)
 696 (*    <include-dir> =INCLUDE 'filename'                             *)
 697 (* InfoType will contain the type of the comment                    *)
 698 (* Info will contain <graphref> or the filename in <include-dir> if *)
 699 (* the Comment isn't an ordinary comment                            *)
 700 (* /*#E*/ do not count this line                                    *)
 701 (* /*#S*/ substructure generated from graphic short hand            *)
 702 procedure ExtractCommentInfo; (*(
 703   var Comment,
 704       Info     : NameString;
 705   var InfoType : TypeOfComment); *)
 706
 707 const
 708   CommentMarkLength = 2;
 709   IncludeMarkLength = 7;  (* = INCLUDE *)
 710   GRRefLen = 6;
 711 var StartIndex,
 712     Index : integer;
 713 begin   (* ExtractCommentInfo *)
 714   Info.Length := 0;
 715   with Comment do begin
 716     InfoType := Ordinary;
 717     StartIndex := CommentMarkLength + 1;
 718     if Length > StartIndex then
 719       if Value[StartIndex] = '#' then
 720         if Value[StartIndex+1] in ['I','i', 'S'] then begin
 721           if (Value[StartIndex+1] = 'S') and (Length = StartIndex+1+2) then
 722             InfoType := SubstrShortHand
 723           else if (Value[StartIndex+1] = 'S') and
 724             (Length > StartIndex + GRRefLen) then begin
 725               if Value[StartIndex+2] = 'D' then
 726                 if Value[StartIndex+3] = 'T' then
 727                   if Value[StartIndex+4] = 'R' then
 728                     if Value[StartIndex+5] = 'E' then
 729                       if Value[StartIndex+6] = 'F' then
 730                         InfoType := GRRef;
 731             end
 732           else begin
 733             if Length > StartIndex + IncludeMarkLength then
 734               if Value[StartIndex+2] in ['N','n'] then
 735                 if Value[StartIndex+3] in ['C','c'] then
 736                   if Value[StartIndex+4] in ['L','l'] then
 737                    if Value[StartIndex+5] in ['U','u'] then
 738                      if Value[StartIndex+6] in ['D','d'] then
 739                        if Value[StartIndex+7] in ['E','e'] then
 740                          InfoType := IncludeClause;
 741           end;
 742         end;
 743
 744     if InfoType = IncludeClause then begin
 745       InfoType := Ordinary;
 746       StartIndex := StartIndex + IncludeMarkLength + 1;
 747       if StartIndex+3 <= Length-2 then (* excluding the comment-end '*/' *) begin
 748         if Value[StartIndex] = ' ' then begin
 749           while (StartIndex <= Length-2) and (Value[StartIndex] = ' ') do
 750             StartIndex := StartIndex + 1;           (* Skip the spaces *)
 751           if Value[StartIndex] = '''' then begin
 752             Index := StartIndex+1;
 753             while (Index <= Length-2) and (Value[Index] <> '''') do begin
 754               Info.Value[Index-StartIndex] := Value[Index];
 755               Index := Index + 1;
 756             end;
 757             if Value[Index] = '''' then begin
 758               Info.Length := Index - StartIndex - 1;
 759               Index := Index + 1;
 760               while (Index <= Length-2) and (Value[Index] = ' ') do
 761                 Index := Index + 1;           (* Skip the ending spaces *)
 762               if Index = Length-1 then
 763                 InfoType := IncludeClause;  (* => a correct include directive *)
 764             end;
 765           end;
 766         end;
 767       end;
 768     end
 769     else if InfoType = SubstrShortHand then
 770       Info := chartonmstr('S')
 771     else if InfoType = GRRef then begin
 772       if (Value[Length] = '/') and (Value[Length - 1] = '*') then
 773         Info := SubString(Comment, StartIndex, Length - StartIndex + 1 - 2)
 774       else (* truncated *)
 775         Info := SubString(Comment, StartIndex, Length - StartIndex + 1);
 776     end;
 777   end;
 778 end;    (* ExtractCommentInfo *)
 779
 780 (*---------------------------------------------------------------------------*)
 781 (* inserts a node in a binary tree sorted after value. If node
 782    is in tree Found returns true.  *)
 783
 784 procedure INSERT_TREE_NODE;(*(
 785             New_node: BinNodePointer;  node to insert
 786             var Node: BinNodePointer;  tree to insert in
 787             var FoundNode : BinNodePointer;
 788             var Found : boolean;       return status of operation
 789             var Higher: boolean);   returned true if the subtree height has
 790                                        increased *)
 791
 792 var
 793
 794   Node_1,                    (* helpvariable to rotate nodes *)
 795   Node_2: BinNodePointer; (* helpvariable to rotate nodes *)
 796
 797 begin
 798
 799   if Node = nil then
 800   begin  (* Value is not in tree, insert *)
 801     Node:= New_node;
 802     FoundNode := Node;
 803     Higher:=  true;
 804   end
 805   else
 806
 807        (* New_node^.Value < Node^.Value *)
 808     if NameStringLess(New_node^.NameP^, Node^.NameP^) then
 809     begin  (* New Value is lower than actual Value *)
 810       INSERT_TREE_NODE( New_node, Node^.left, FoundNode, Found, Higher);
 811
 812       if Higher then  (* left bransch has grown higher *)
 813       case Node^.bal of
 814
 815         1: begin
 816              Node^.bal:= 0;
 817              Higher:= false;
 818            end;
 819
 820         0: begin
 821              Node^.bal:= -1;
 822            end;
 823
 824        -1: begin  (* rebalance *)
 825              Node_1:= Node^.left;
 826
 827              if Node_1^.bal = -1 then
 828              begin  (* single LL rotation *)
 829                Node^.left:= Node_1^.right;
 830                Node_1^.right:= Node;
 831                Node^.bal:= 0;
 832                Node:= Node_1;
 833              end
 834              else
 835
 836              begin  (* double LR rotation *)
 837                Node_2:= Node_1^.right;
 838                Node_1^.right:= Node_2^.left;
 839                Node_2^.left:= Node_1;
 840                Node^.left:= Node_2^.right;
 841                Node_2^.right:= Node;
 842
 843                if Node_2^.bal = -1 then
 844                  Node^.bal:= 1
 845                else
 846                  Node^.bal:= 0;
 847
 848                if Node_2^.bal = 1 then
 849                  Node_1^.bal:= -1
 850                else
 851                  Node_1^.bal:= 0;
 852                Node:= Node_2;
 853              end;
 854              Node^.bal:= 0;
 855              Higher:= false;
 856            end;
 857       end; (* end case Node^.bal of *)
 858     end
 859     else
 860
 861          (* New_node^.value > Node^.value *)
 862       if NameStringLess(Node^.NameP^, New_Node^.NameP^) then
 863       begin  (* New value is higher than actual value *)
 864         INSERT_TREE_NODE( New_node, Node^.right, FoundNode, Found, Higher);
 865
 866         if Higher then  (* Right bransch has grown higher *)
 867         case Node^.bal of
 868
 869          -1: begin
 870                Node^.bal:= 0;
 871                Higher:= false;
 872              end;
 873
 874           0: begin
 875                Node^.bal:= 1;
 876              end;
 877
 878           1: begin  (* Rebalance *)
 879                Node_1:= Node^.right;
 880
 881                if Node_1^.bal = 1 then
 882                begin  (* single RR rotation *)
 883                  Node^.right:= Node_1^.left;
 884                  Node_1^.left:= Node;
 885                  Node^.bal:= 0;
 886                  Node:= Node_1;
 887                end
 888                else
 889                begin  (* double RL rotation *)
 890                  Node_2:= Node_1^.left;
 891                  Node_1^.left:= Node_2^.right;
 892                  Node_2^.right:= Node_1;
 893                  Node^.right:= Node_2^.left;
 894                  Node_2^.left:= Node;
 895
 896                  if Node_2^.bal = 1 then
 897                    Node^.bal:= -1
 898                  else
 899                    Node^.bal:= 0;
 900
 901                  if Node_2^.bal = -1 then
 902                    Node_1^.bal:= 1
 903                  else
 904                    Node_1^.bal:= 0;
 905                  Node:= Node_2;
 906                end;
 907                Node^.bal:= 0;
 908                Higher:= false;
 909              end;
 910         end; (* end case Node^.bal of *)
 911       end
 912       else
 913       begin  (* New value is equal to actual value *)
 914         Found := true;
 915         FoundNode := Node;
 916         Higher:= false;
 917       end;
 918 end;  (* end INSERT_TREE_NODE *)
 919
 920 function GetNameList; (* : BinNodePointer;*)
 921 begin
 922   GetNameList := NameList;
 923 end;
 924
 925 procedure DisposeANameList(
 926   var NodeP : BinNodePointer);
 927 begin (* DisposeANameList *)
 928   if NodeP <> nil then begin
 929     DisposeANameList(NodeP^.Left);
 930     DisposeANameList(NodeP^.Right);
 931     NodeP^.Left := AvailNameList;
 932     NodeP^.Right := nil;
 933     AvailNameList := NodeP;
 934     NodeP := nil;
 935   end;
 936 end; (* DisposeANameList *)
 937
 938 procedure DisposeNameList;
 939 begin
 940   DisposeANameList(NameList);
 941 end;
 942
 943 function GetNewNameListNode;(*(
 944   var Name  : NameString) : BinNodePointer;*)
 945 var
 946   NodeP : BinNodePointer;
 947 begin (* GetNewNameListNode *)
 948   if AvailNameList = nil then begin
 949     new(NodeP);
 950     with NodeP^ do begin
 951       Left := nil;
 952       Right := nil;
 953       Bal := 0;
 954       new(NameP);
 955       Namep^ := Name;
 956     end;
 957   end
 958   else begin
 959     NodeP := AvailNameList;
 960     AvailNameList := NodeP^.Left;
 961     with NodeP^ do begin
 962       Left := nil;
 963       Bal := 0;
 964       Namep^ := Name;
 965     end;
 966   end;
 967   GetNewNameListNode := NodeP;
 968 end; (* GetNewNameListNode *)
 969
 970 (*---------------------------------------------------------------------------*)
 971
 972 function insertname;(*(
 973       Name  : NameString;
 974   var Found : boolean) : NameStringPointer;*)
 975 var
 976   Higher : boolean;
 977   NodeP  : BinNodePointer;
 978   FoundNode : BinNodePointer;
 979 begin (* insertname *)
 980   NodeP := GetNewNameListNode(Name);
 981   Found := false;
 982   INSERT_TREE_NODE(NodeP, NameList, FoundNode, Found, Higher);
 983   insertname := FoundNode^.NameP;
 984   if Found then
 985     DisposeANameList(NodeP);
 986 end; (* insertname *)
 987
 988 procedure InitNameList;
 989 begin
 990   NameList := nil;
 991   AvailNameList := nil;
 992 end;
 993
 994 (********************************************************************)
 995 (*                      NameString - Dynamic Memory Allocation      *)
 996 (********************************************************************)
 997
 998 procedure InitNameStringPool;
 999 begin
1000   GlobalNSPool.Avail := nil;
1001   GlobalNSPool.Empty := nil;
1002 end;
1003
1004 procedure NewNameString; (* (var NSP: NameStringPointer );*)
1005 (*var Temp: NSPoolP;*)
1006 begin
1007 (*
1008   if GlobalNSPool.Avail=nil then
1009     new( NSP )
1010   else begin
1011     Temp := GlobalNSPool.Avail;
1012     GlobalNSPool.Avail := Temp^.Next;
1013     Temp^.Next := GlobalNSPool.Empty;
1014     GlobalNSPool.Empty := Temp;
1015     NSP := Temp^.Data;
1016   end;
1017 *)
1018   new(NSP);
1019   NSP^.Length := 0;
1020 end;
1021
1022 procedure ReleaseNameString; (* (var NSP: NameStringPointer );*)
1023 (*var Temp: NSPoolP;*)
1024 begin
1025   if NSP <> nil then begin
1026 (*
1027     if GlobalNSPool.Empty=nil then begin
1028       new(Temp);
1029       Temp^.Next := GlobalNSPool.Avail;
1030       GlobalNSPool.Avail := Temp;
1031     end
1032     else begin
1033       Temp := GlobalNSPool.Empty;
1034       GlobalNSPool.Empty := Temp^.Next;
1035       Temp^.Next := GlobalNSPool.Avail;
1036       GlobalNSPool.Avail := Temp;
1037     end;
1038     Temp^.Data := NSP;
1039 *)
1040     dispose(NSP);
1041     NSP := nil;
1042   end;
1043 end;
1044
1045 procedure SDTrefStringToRec (* (
1046   var S : SDTrefString;
1047   var R : SDTrefRec;
1048   var Error : integer) *) ;
1049
1050 (* Converts SDTrefString S to a record R (SDTrefRec). If an error is
1051    detected Error is on exit the position in S where the error where
1052    detected. If correct Error is 0. *)
1053
1054 label 99;
1055 var
1056   Len : integer;
1057   ErrorFound, EndFound : Boolean;
1058
1059 procedure SDTrefSkipSpaces;
1060 var Found : Boolean;
1061 begin
1062   Found := false;
1063   while not Found and (Len <= S.Length) do
1064     if (S.Value[Len] = ' ') or (S.Value[Len] = chr(9)) then
1065       Len := Len+1
1066     else
1067       Found := true;
1068 end;
1069
1070 function SDTrefIsEnd : Boolean;
1071 begin
1072   SDTrefIsEnd := false;
1073   if S.Value[Len] = ')' then
1074   begin
1075     Len := Len+1;
1076     SDTrefSkipSpaces;
1077     if Len > S.Length then
1078       SDTrefIsEnd := true;
1079   end;
1080 end;
1081
1082 function SDTrefGetInteger : integer;
1083 var
1084   Temp : NameString;
1085   Found : Boolean;
1086 begin
1087   Temp.Length := 0;
1088   Found := false;
1089   while not Found and (Temp.Length <= NameStringLength) and
1090                       (Len <= S.Length) do
1091     if S.Value[Len] in ['0'..'9'] then
1092     begin
1093       Temp.Length := Temp.Length+1;
1094       Temp.Value[Temp.Length] := S.Value[Len];
1095       Len := Len+1;
1096     end
1097     else
1098       Found := true;
1099   if Temp.Length > 0 then
1100     SDTrefGetInteger := NmStrToInteger(Temp)
1101   else
1102     SDTrefGetInteger := SDTrefUndefInt;
1103 end;
1104
1105 begin
1106   ErrorFound := true;
1107   R.IsSDTGR := true;
1108   R.FileName.Length := 0;
1109   R.PageName.Length := 0;
1110   R.ObjectId := SDTrefUndefInt;
1111   R.XCoord := SDTrefUndefInt;
1112   R.YCoord := SDTrefUndefInt;
1113   R.LineNumber := SDTrefUndefInt;
1114   R.Column := SDTrefUndefInt;
1115
1116   Len := 1;
1117   if S.Length = 0 then goto 99;
1118   if S.Value[1] <> '#' then goto 99;
1119   Len := 2;
1120   if S.Value[2] <> 'S' then goto 99;
1121   Len := 3;
1122   if S.Value[3] <> 'D' then goto 99;
1123   Len := 4;
1124   if S.Value[4] <> 'T' then goto 99;
1125   Len := 5;
1126   if S.Value[5] <> 'R' then goto 99;
1127   Len := 6;
1128   if S.Value[6] <> 'E' then goto 99;
1129   Len := 7;
1130   if S.Value[7] <> 'F' then goto 99;
1131   Len := 8;
1132   if S.Value[8] <> '(' then goto 99;
1133   Len := 9;
1134
1135   if S.Value[9] = 'S' then
1136   begin
1137     Len := 10;
1138     if S.Value[10] <> 'D' then goto 99;
1139     Len := 11;
1140     if S.Value[11] <> 'L' then goto 99;
1141     Len := 12; SDTrefSkipSpaces;
1142     if Len > S.Length then goto 99;
1143
1144     (* First comma *)
1145     if S.Value[Len] <> ',' then goto 99;
1146     Len := Len+1; SDTrefSkipSpaces;
1147     if Len > S.Length then goto 99;
1148
1149     (* FileName *)
1150     EndFound := false;
1151     while not EndFound and (Len <= S.Length) do
1152       if S.Value[Len] in [',', ')', '(', ' ', chr(9)] then
1153         EndFound := true
1154       else
1155       begin
1156         R.FileName.Length := R.FileName.Length+1;
1157         if R.FileName.Length > S.Length then goto 99;
1158         R.FileName.Value[R.FileName.Length] := S.Value[Len];
1159         Len := Len+1;
1160         if Len > S.Length then goto 99;
1161       end;
1162     SDTrefSkipSpaces;
1163     if Len > S.Length then goto 99;
1164
1165     (* PageName *)
1166     if S.Value[Len] = '(' then
1167     begin
1168       Len := Len+1; SDTrefSkipSpaces;
1169       if Len > S.Length then goto 99;
1170       EndFound := false;
1171       while not EndFound and (Len <= S.Length) do
1172         if S.Value[Len] in [',', ')', '(', ' ', chr(9)] then
1173           EndFound := true
1174         else
1175         begin
1176           R.PageName.Length := R.PageName.Length+1;
1177           if R.PageName.Length > NameStringLength then goto 99;
1178           R.PageName.Value[R.PageName.Length] := S.Value[Len];
1179           Len := Len+1;
1180           if Len > S.Length then goto 99;
1181         end;
1182       SDTrefSkipSpaces;
1183       if Len > S.Length then goto 99;
1184       if S.Value[Len] <> ')' then goto 99;
1185       Len := Len+1; SDTrefSkipSpaces;
1186       if Len > S.Length then goto 99;
1187     end;
1188     if SDTrefIsEnd then begin ErrorFound := false; goto 99; end;
1189
1190     if S.Value[Len] <> ',' then goto 99;
1191     Len := Len+1; SDTrefSkipSpaces;
1192     if Len > S.Length then goto 99;
1193
1194     (* ObjectId *)
1195     R.ObjectId := SDTrefGetInteger;
1196     SDTrefSkipSpaces;
1197     if Len > S.Length then goto 99;
1198
1199     (* Object_Coordinates *)
1200     if S.Value[Len] = '(' then
1201     begin
1202       Len := Len+1; SDTrefSkipSpaces;
1203       if Len > S.Length then goto 99;
1204       R.XCoord := SDTrefGetInteger;
1205       SDTrefSkipSpaces;
1206       if Len > S.Length then goto 99;
1207       if S.Value[Len] <> ',' then goto 99;
1208       Len := Len+1; SDTrefSkipSpaces;
1209       if Len > S.Length then goto 99;
1210       R.YCoord := SDTrefGetInteger;
1211       SDTrefSkipSpaces;
1212       if Len > S.Length then goto 99;
1213       if S.Value[Len] <> ')' then goto 99;
1214       Len := Len+1; SDTrefSkipSpaces;
1215       if Len > S.Length then goto 99;
1216     end;
1217     if SDTrefIsEnd then begin ErrorFound := false; goto 99; end;
1218
1219     if S.Value[Len] <> ',' then goto 99;
1220     Len := Len+1; SDTrefSkipSpaces;
1221     if Len > S.Length then goto 99;
1222
1223     (* LineNumber *)
1224     R.LineNumber := SDTrefGetInteger;
1225     SDTrefSkipSpaces;
1226     if Len > S.Length then goto 99;
1227     if SDTrefIsEnd then begin ErrorFound := false; goto 99; end;
1228
1229     if S.Value[Len] <> ',' then goto 99;
1230     Len := Len+1; SDTrefSkipSpaces;
1231     if Len > S.Length then goto 99;
1232
1233     (* Column *)
1234     R.Column := SDTrefGetInteger;
1235     SDTrefSkipSpaces;
1236     if Len > S.Length then goto 99;
1237     if SDTrefIsEnd then ErrorFound := false;
1238   end
1239
1240   else if S.Value[9] = 'T' then
1241   begin
1242     Len := 10;
1243     R.IsSDTGR := false;
1244     if S.Value[10] <> 'E' then goto 99;
1245     Len := 11;
1246     if S.Value[11] <> 'X' then goto 99;
1247     Len := 12;
1248     if S.Value[12] <> 'T' then goto 99;
1249     Len := 13; SDTrefSkipSpaces;
1250     if Len > S.Length then goto 99;
1251
1252     (* First comma *)
1253     if S.Value[Len] <> ',' then goto 99;
1254     Len := Len+1; SDTrefSkipSpaces;
1255     if Len > S.Length then goto 99;
1256
1257     (* FileName *)
1258     EndFound := false;
1259     while not EndFound and (Len <= S.Length) do
1260       if S.Value[Len] in [',', ')', '(', ' ', chr(9)] then
1261         EndFound := true
1262       else
1263       begin
1264         R.FileName.Length := R.FileName.Length+1;
1265         if R.FileName.Length > S.Length then goto 99;
1266         R.FileName.Value[R.FileName.Length] := S.Value[Len];
1267         Len := Len+1;
1268         if Len > S.Length then goto 99;
1269       end;
1270     SDTrefSkipSpaces;
1271     if Len > S.Length then goto 99;
1272     if SDTrefIsEnd then begin ErrorFound := false; goto 99; end;
1273
1274     if S.Value[Len] <> ',' then goto 99;
1275     Len := Len+1; SDTrefSkipSpaces;
1276     if Len > S.Length then goto 99;
1277
1278     (* LineNumber *)
1279     R.LineNumber := SDTrefGetInteger;
1280     SDTrefSkipSpaces;
1281     if Len > S.Length then goto 99;
1282     if SDTrefIsEnd then begin ErrorFound := false; goto 99; end;
1283
1284     if S.Value[Len] <> ',' then goto 99;
1285     Len := Len+1; SDTrefSkipSpaces;
1286     if Len > S.Length then goto 99;
1287
1288     (* Column *)
1289     R.Column := SDTrefGetInteger;
1290     SDTrefSkipSpaces;
1291     if Len > S.Length then goto 99;
1292     if SDTrefIsEnd then ErrorFound := false;
1293   end;
1294
1295 99:
1296   if ErrorFound then
1297     Error := Len
1298   else
1299     Error := 0;
1300 end;
1301
1302
1303 procedure SDTrefRecToString  (* (
1304   var R : SDTrefRec;
1305   var S : SDTrefString) *) ;
1306
1307 (* Converts SDTrefRec R to a string S (SDTrefString). If an error is
1308    detected (string is not long enough) S.Length becomes 0 on exit *)
1309
1310 label 99;
1311 var
1312   Len, I : integer;
1313   Temp : NameString;
1314 begin
1315   S.Value[1] := '#';
1316   S.Value[2] := 'S';
1317   S.Value[3] := 'D';
1318   S.Value[4] := 'T';
1319   S.Value[5] := 'R';
1320   S.Value[6] := 'E';
1321   S.Value[7] := 'F';
1322   S.Value[8] := '(';
1323   S.Length := 8;
1324   if R.IsSDTGR then
1325   begin
1326     Temp.Value[1] := 'S';
1327     Temp.Value[2] := 'D';
1328     Temp.Value[3] := 'L';
1329     Temp.Value[4] := ',';
1330     Temp.Length := 4;
1331     S := Concatenatenamestrings(S, Temp);
1332     Len := S.Length;
1333     (* FileName *)
1334     for I := 1 to R.FileName.Length do
1335     begin
1336       Len := Len+1;
1337       if Len > SDTrefStringLength then goto 99;
1338       S.Value[Len] := R.FileName.Value[I];
1339     end;
1340
1341     (* PageName *)
1342     if R.PageName.Length > 0 then
1343     begin
1344       Len := Len+1;
1345       if Len > SDTrefStringLength then goto 99;
1346       S.Value[Len] := '(';
1347       for I := 1 to R.PageName.Length do
1348       begin
1349         Len := Len+1;
1350         if Len > SDTrefStringLength then goto 99;
1351         S.Value[Len] := R.PageName.Value[I];
1352       end;
1353       Len := Len+1;
1354       if Len > SDTrefStringLength then goto 99;
1355       S.Value[Len] := ')';
1356     end;
1357
1358     (* ObjectId *)
1359     if R.ObjectId <> SDTrefUndefInt then
1360     begin
1361       Len := Len+1;
1362       if Len > SDTrefStringLength then goto 99;
1363       S.Value[Len] := ',';
1364       Temp := integertonmstr(R.ObjectId);
1365       for I := 1 to Temp.Length do
1366       begin
1367         Len := Len+1;
1368         if Len > SDTrefStringLength then goto 99;
1369         S.Value[Len] := Temp.Value[I];
1370       end;
1371     end;
1372
1373     (* Object_Coordinates *)
1374     if R.XCoord <> SDTrefUndefInt then
1375     begin
1376       Len := Len+1;
1377       if Len > SDTrefStringLength then goto 99;
1378       S.Value[Len] := '(';
1379       Temp := integertonmstr(R.XCoord);
1380       for I := 1 to Temp.Length do
1381       begin
1382         Len := Len+1;
1383         if Len > SDTrefStringLength then goto 99;
1384         S.Value[Len] := Temp.Value[I];
1385       end;
1386       Len := Len+1;
1387       if Len > SDTrefStringLength then goto 99;
1388       S.Value[Len] := ',';
1389       Temp := integertonmstr(R.YCoord);
1390       for I := 1 to Temp.Length do
1391       begin
1392         Len := Len+1;
1393         if Len > SDTrefStringLength then goto 99;
1394         S.Value[Len] := Temp.Value[I];
1395       end;
1396       Len := Len+1;
1397       if Len > SDTrefStringLength then goto 99;
1398       S.Value[Len] := ')';
1399     end;
1400
1401     (* LineNumber *)
1402     if R.LineNumber <> SDTrefUndefInt then
1403     begin
1404       Len := Len+1;
1405       if Len > SDTrefStringLength then goto 99;
1406       S.Value[Len] := ',';
1407       Temp := integertonmstr(R.LineNumber);
1408       for I := 1 to Temp.Length do
1409       begin
1410         Len := Len+1;
1411         if Len > SDTrefStringLength then goto 99;
1412         S.Value[Len] := Temp.Value[I];
1413       end;
1414     end;
1415
1416     (* Column *)
1417     if R.Column <> SDTrefUndefInt then
1418     begin
1419       Len := Len+1;
1420       if Len > SDTrefStringLength then goto 99;
1421       S.Value[Len] := ',';
1422       Temp := integertonmstr(R.Column);
1423       for I := 1 to Temp.Length do
1424       begin
1425         Len := Len+1;
1426         if Len > SDTrefStringLength then goto 99;
1427         S.Value[Len] := Temp.Value[I];
1428       end;
1429     end;
1430
1431     Len := Len+1;
1432     if Len > SDTrefStringLength then goto 99;
1433     S.Value[Len] := ')';
1434   end
1435
1436   else  (* if PR *)
1437
1438   begin
1439     Temp.Value[1] := 'T';
1440     Temp.Value[2] := 'E';
1441     Temp.Value[3] := 'X';
1442     Temp.Value[4] := 'T';
1443     Temp.Value[5] := ',';
1444     Temp.Length := 5;
1445     S := Concatenatenamestrings(S, Temp);
1446     Len := S.Length;
1447     (* FileName *)
1448     for I := 1 to R.FileName.Length do
1449     begin
1450       Len := Len+1;
1451       if Len > SDTrefStringLength then goto 99;
1452       S.Value[Len] := R.FileName.Value[I];
1453     end;
1454
1455     (* LineNumber *)
1456     if R.LineNumber <> SDTrefUndefInt then
1457     begin
1458       Len := Len+1;
1459       if Len > SDTrefStringLength then goto 99;
1460       S.Value[Len] := ',';
1461       Temp := integertonmstr(R.LineNumber);
1462       for I := 1 to Temp.Length do
1463       begin
1464         Len := Len+1;
1465         if Len > SDTrefStringLength then goto 99;
1466         S.Value[Len] := Temp.Value[I];
1467       end;
1468     end;
1469
1470     (* Column *)
1471     if R.Column <> SDTrefUndefInt then
1472     begin
1473       Len := Len+1;
1474       if Len > SDTrefStringLength then goto 99;
1475       S.Value[Len] := ',';
1476       Temp := integertonmstr(R.Column);
1477       for I := 1 to Temp.Length do
1478       begin
1479         Len := Len+1;
1480         if Len > SDTrefStringLength then goto 99;
1481         S.Value[Len] := Temp.Value[I];
1482       end;
1483     end;
1484
1485     Len := Len+1;
1486     if Len > SDTrefStringLength then goto 99;
1487     S.Value[Len] := ')';
1488   end;
1489
1490 99:
1491   if Len > SDTrefStringLength then
1492     S.Length := 0
1493   else
1494     S.Length := Len;
1495 end;
1496
1497 function NmStrToErrStr;(*(
1498   NmStr : NameString) : ErrorString;*)
1499 var
1500   ErrStr : ErrorString;
1501   i : integer;
1502 begin
1503   for i := 1 to NmStr.Length do
1504     ErrStr.Value[i] := NmStr.Value[i];
1505   ErrStr.Length := NmStr.Length;
1506   NmStrToErrStr := ErrStr;
1507 end;
1508
1509 function ErrStrToNmStr;(*(
1510   ErrStr : ErrorString) : NameString;*)
1511 var
1512   NmStr : NameString;
1513   i : integer;
1514   n : integer;
1515 begin
1516   if ErrStr.Length < NameStringLength then
1517     n := ErrStr.Length
1518   else
1519     n := NameStringLength;
1520   for i := 1 to n do
1521     NmStr.Value[i] := ErrStr.Value[i];
1522   NmStr.Length := n;
1523   ErrStrToNmStr := NmStr;
1524 end;
1525
1526 (*------------------------------------------------------------------*)
1527 (*                   GetTextRef                                     *)
1528 (*------------------------------------------------------------------*)
1529 function GetTextRef;(*(
1530   FNm : NameString;
1531   Ln : integer;
1532   Col : integer) : NameString;*)
1533 var
1534   Ref : SDTrefRec;
1535   S : NameString;
1536 begin(* GetTextRef *)
1537   Ref.IsSDTGR := false;
1538   Ref.FileName := FNm;
1539   Ref.LineNumber := Ln;
1540   Ref.Column := Col;
1541   SDTrefRecToString(Ref, S);
1542   GetTextRef := S;
1543 end; (* GetTextRef *)
1544
1545  (* module COMMON *)