7 Data
: NameStringPointer
;
13 Avail
, Empty
: NSPoolP
;
17 AvailString
: TextString
;
18 NameList
: BinNodePointer
;
19 AvailNameList
: BinNodePointer
;
23 (*------------------------------------------------------------------*)
24 (* InitializeStringPackage *)
25 (*------------------------------------------------------------------*)
26 procedure InitializeStringPackage
;
27 begin (* InitializeStringPackage *)
29 end; (* InitializeStringPackage *)
31 (*------------------------------------------------------------------*)
33 (*------------------------------------------------------------------*)
34 function newtextstring
; (*: TextString;*)
37 begin (* newtextstring *)
38 if AvailString
= nil then
42 AvailString
:= Temp
^.Next
;
44 Temp
^.String.Length
:= 0;
46 newtextstring
:= Temp
;
47 end; (* newtextstring *)
49 (*------------------------------------------------------------------*)
50 (* disposetextstring *)
51 (*------------------------------------------------------------------*)
52 procedure disposetextstring
;(*(
53 var S : TextString);*)
57 begin (* disposetextstring *)
58 if S
<> nil then begin
61 while Temp^.Next <> nil do
63 Temp^.Next := AvailString;
73 end; (* disposetextstring *)
75 (*------------------------------------------------------------------*)
77 (*------------------------------------------------------------------*)
79 ToString : TextString;
80 S : TextString) : TextString;*)
85 if ToString
= nil then
86 writeln (output
, 'Error in ConcatT, ToString is nil')
89 writeln (output
, 'Error in ConcatT, S is nil')
91 if S
^.Next
<> nil then
93 'Error in ConcatT, S contains several linked TextStrings')
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
;
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
;
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')
121 writeln (output
, 'Error in AppendTextString, S is nil')
123 while ToString
^.Next
<> nil do
124 ToString
:= ToString
^.Next
;
127 end; (* AppendTextString *)
129 (*------------------------------------------------------------------*)
131 (*------------------------------------------------------------------*)
132 function CopyTextString
;(*(
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
;
145 CopyTextString
:= nil;
146 end; (* CopyTextString *)
148 (*------------------------------------------------------------------*)
149 (* CONVERT_CHARSTRING_TO_VALUE *)
150 (*------------------------------------------------------------------*)
151 procedure CONVERT_CHARSTRING_TO_VALUE
;(*(
153 var V : NameString);*)
158 begin (* CONVERT_CHARSTRING_TO_VALUE *)
160 for Pos
:= 2 to S
.Length
- 1 do begin
162 if not ((Ch
= '''') and (Pos
> 2) and (S
.Value
[Pos
- 1] = '''')) then
167 end; (* CONVERT_CHARSTRING_TO_VALUE *)
169 (*------------------------------------------------------------------*)
171 (*------------------------------------------------------------------*)
172 procedure append_string
;(*(
173 var Txt : TextString;
174 var String : NameString);*)
177 begin (* append_string *)
178 Temp
:= newtextstring
;
179 Temp
^.String := String;
183 Txt
:= AppendTextString(Txt
, Temp
);
184 end; (* append_string *)
186 function To_Upper
;(*(ch:char) : char;*)
188 if ch
in ['a'..'z'] then
189 To_Upper
:= chr(ord(ch
) + ord('A')-ord('a'))
194 function To_Lower
;(*(ch:char) : char;*)
196 if ch
in ['A'..'Z'] then
197 To_Lower
:= chr(ord(ch
) - ord('A') + ord('a'))
202 (*----------------------------------------------------------------------*)
203 (* Operations on NameString *)
204 (*----------------------------------------------------------------------*)
206 (*------------------------------------------------------------------*)
208 (*------------------------------------------------------------------*)
209 function EmptyNmStr(* : NameString*);
212 begin (* EmptyNmStr *)
215 end; (* EmptyNmStr *)
218 (* returns a namestring containing one character, the inparameter Ch *)
219 function chartonmstr
; (*(
220 Ch : Char) : NameString; *)
224 String.Value
[1] := Ch
;
226 chartonmstr
:= String;
229 (* returns a namestring containing the inparameter Str in lowercase letters *)
230 function LowerCaseNmStr
; (*(
231 Str : NameString) : NameString; *)
234 begin (* LowerCaseNmStr *)
236 for i
:= 1 to Length
do
237 Value
[i
] := To_Lower(Value
[i
]);
238 LowerCaseNmStr
:= Str
;
239 end; (* LowerCaseNmStr *)
241 (* returns a namestring containing inparameter S1 concatenated with inpar. S2 *)
242 function concatenatenamestrings
; (*(
244 S2 : NameString) : NameString; *)
248 begin (* concatenatenamestrings *)
252 while Pos
< S2
.Length
do begin
254 if Length
< NameStringLength
then begin
255 Length
:= Length
+ 1;
256 Value
[Length
] := S2
.Value
[Pos
];
260 concatenatenamestrings
:= Temp
;
261 end; (* concatenatenamestrings *)
263 procedure writenamestring
;(*(
265 var Name : NameString);*)
270 for Pos
:= 1 to Length
do
271 write(TextFile
, Value
[Pos
]);
274 (*------------------------------------------------------------------*)
276 (*------------------------------------------------------------------*)
277 function IsControlChar
; (*(
278 Ch : char) : boolean; *)
279 begin (* IsControlChar *)
280 IsControlChar
:= ord(Ch
) in [0..32, 127];
281 end; (* IsControlChar *)
283 function namestringequal
;(*(var Name1,Name2 : NameString) : Boolean;*)
287 if Name1
.Length
= Name2
.Length
then begin
290 while (i
<= Name1
.Length
) and equal
do begin
291 equal
:= To_Upper(Name1
.Value
[i
]) = To_Upper(Name2
.Value
[i
]);
294 namestringequal
:= equal
;
297 namestringequal
:= false;
300 (* Character strings are case sensitive *)
302 function NameStringLess
;(*(var Name1,Name2 : NameString) : Boolean;*)
303 var i
, minlength
: Integer;
306 Charstring
: boolean;
310 if Name1
.Length
< Name2
.Length
then
311 minlength
:= Name1
.Length
313 minlength
:= Name2
.Length
;
314 if MinLength
> 0 then
315 Charstring
:= (Name1
.Value
[1] = '''') or (Name2
.Value
[1] = '''')
318 (* Charstring := true; force case sensitive *)
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
];
328 C1
:= To_Upper(Name1
.Value
[i
]);
329 C2
:= To_Upper(Name2
.Value
[i
]);
335 NameStringLess
:= Name1
.Length
< Name2
.Length
337 NameStringLess
:= C1
< C2
;
340 (*------------------------------------------------------------------*)
341 (* IsControlCharName *)
342 (*------------------------------------------------------------------*)
343 function IsControlCharName(
345 Pos
: integer) : boolean;
346 begin (* IsControlCharName *)
348 if Pos
<= Length
then
349 IsControlCharName
:= IsControlChar(Value
[Pos
])
351 IsControlCharName
:= false;
353 end; (* IsControlCharName *)
355 (*------------------------------------------------------------------*)
357 (*------------------------------------------------------------------*)
358 function SubString
; (*(
361 Len : integer) : NameString; *)
364 begin (* SubString *)
367 for i
:= Start
to Start
+ Len
- 1 do
368 Value
[i
- Start
+ 1] := Value
[i
]
376 (*------------------------------------------------------------------*)
378 (*------------------------------------------------------------------*)
379 function SkipChars
; (*(
382 Len : integer) : NameString; *)
385 begin (* SkipChars *)
387 for i
:= Start
to Length
- Len
do
388 Value
[i
] := Value
[i
+ Len
];
389 Length
:= Length
- Len
;
394 (*------------------------------------------------------------------*)
395 (* RemoveUnderlineControl *)
396 (*------------------------------------------------------------------*)
397 function RemoveUnderlineControl
; (*(
398 Str : NameString) : NameString; *)
403 begin (* RemoveUnderlineControl *)
406 while i
<= Length
do begin
407 if Value
[i
] = '_' then begin
410 while IsControlCharName(Str
, i
+ 1 + Len
) do
413 Str
:= SkipChars(Str
, Start
, Len
+ 1)
421 RemoveUnderlineControl
:= Str
;
422 end; (* RemoveUnderlineControl *)
424 (*------------------------------------------------------------------*)
426 (*------------------------------------------------------------------*)
427 procedure First100Chars
; (*(
429 var Str : NameString;
430 var Truncated : boolean); *)
434 begin (* First100Chars *)
436 if Txt
<> nil then begin
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
447 Len
:= NameStringLength
;
448 for i
:= Str
.Length
+ 1 to Len
do
449 Str
.Value
[i
] := Value
[i
- Str
.Length
];
452 end; (* while with *)
453 Truncated
:= Txt
<> nil;
454 end; (* First100Chars *)
457 (*------------------------------------------------------------------*)
459 (*------------------------------------------------------------------*)
460 (* changes I to contain the first index in Str (starting at I) that *)
462 procedure SkipSpaces
; (* (Str : NameString; var I : Integer);*)
464 begin (* SkipSpaces *)
466 while (I
< Str
.Length
) and not Stop
do
467 if Str
.Value
[I
] <> ' ' then
471 end; (* SkipSpaces *)
474 (*------------------------------------------------------------------*)
476 (*------------------------------------------------------------------*)
477 function SkipBlanks
; (*(
478 TextLine: NameString) : NameString; *)
482 SpaceFound
: boolean;
483 begin (* SkipBlanks *)
484 with TextLine
do begin
487 while SpaceFound
and (i
<= Length
) do begin
488 SpaceFound
:= (Value
[i
] in [' ', chr(9)]);
494 for j
:= 1 to Length
- i
do
495 if j
<= Length
- i
then
496 Value
[j
] := Value
[j
+ i
];
497 Length
:= Length
- i
;
499 SkipBlanks
:= TextLine
;
500 end; (* SkipBlanks *)
502 (*------------------------------------------------------------------*)
504 (*------------------------------------------------------------------*)
505 function stripname
; (* (
506 TextLine: NameString) : NameString; *)
508 SpaceFound
: boolean;
509 begin (* stripname *)
510 TextLine
:= SkipBlanks(TextLine
);
511 with TextLine
do begin
513 while SpaceFound
and (Length
> 0) do begin
514 SpaceFound
:= (Value
[Length
] in [' ', chr(9)]);
516 Length
:= Length
- 1;
519 stripname
:= TextLine
;
524 Chars : SetOfChar) : integer; *)
532 while not Found
and (Pos
< Length
) do begin
534 Found
:= Value
[Pos
] in Chars
;
540 (*------------------------------------------------------------------*)
542 (*------------------------------------------------------------------*)
543 function NameHasChar
; (* (TheName : NameString; TheChar : char) : boolean;*)
547 begin (* NameHasChar *)
550 while not found
and (i
< TheName
.Length
) do begin
552 found
:= TheName
.Value
[i
] = TheChar
;
554 NameHasChar
:= found
;
555 end; (* NameHasChar *)
558 (*------------------------------------------------------------------*)
560 (*------------------------------------------------------------------*)
561 function integertonmstr
; (* (TheInteger : integer) : NameString; *)
565 TempNumber
: integer;
566 begin (* integertonmstr *)
568 TempNumber
:= TheInteger
;
569 while TempNumber
div 10 > 0 do begin
571 TempNumber
:= TempNumber
div 10;
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;
579 integertonmstr
:= Nm
;
580 end; (* integertonmstr *)
582 (*------------------------------------------------------------------*)
584 (*------------------------------------------------------------------*)
585 function NmStrToInteger
; (* (Str : NameString) : integer; *)
590 begin (* NmStrToInteger *)
591 Max
:= (maxint
div 10) - 10;
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');
597 NmStrToInteger
:= Numb
;
598 end; (* NmStrToInteger *)
600 function AddNullToNmStr
; (*(
601 Nm : NameString) : NameString; *)
602 begin (* AddNullToNmStr *)
604 if Length
< NameStringLength
then
605 Value
[Length
+ 1] := chr(0)
607 Value
[Length
] := chr(0);
608 AddNullToNmStr
:= Nm
;
609 end; (* AddNullToNmStr *)
611 function ValToNmStr
; (*(
612 Nm : NameString) : NameString; *)
613 begin (* ValToNmStr *)
616 while value
[length
+ 1] <> chr(0) do
617 length
:= length
+ 1;
620 end; (* ValToNmStr *)
622 (*------------------------------------------------------------------*)
624 (*------------------------------------------------------------------*)
625 function ChangeFileType
; (*(FileName : NameString;
626 NewType : NameString) : NameString;*)
630 begin (* ChangeFileType *)
631 with Filename
do begin
632 Pos
:= FileName
.Length
;
634 while not Found
and (Pos
> 0) do begin
635 Found
:= Value
[Pos
] = '.';
641 ChangeFileType
:= concatenatenamestrings(FileName
, NewType
);
642 end; (* ChangeFileType*)
644 (*------------------------------------------------------------------*)
646 (*------------------------------------------------------------------*)
647 function StripPath
; (*(
648 Str : NameString) : NameString; *)
653 begin (* StripPath *)
657 while not Found
and (i
> 0) do begin
658 Found
:= Value
[i
] in ['/', '\'];
663 Len
:= Length
- i
+ 1;
664 if i
< Length
then begin
668 StripPath
:= SubString(Str
, i
, Len
);
675 function ReprOfChar
; (*( ch : char) : NameString;*)
679 if (ch
>= ' ') and (ch
<= '~') then
680 Repr
:= chartonmstr(ch
)
682 Repr
:= concatenatenamestrings(concatenatenamestrings(chartonmstr('<'),
683 integertonmstr(ord(ch
))), chartonmstr('>'));
685 end; (* ReprOfChar *)
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 *)
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
; (*(
705 var InfoType : TypeOfComment); *)
708 CommentMarkLength
= 2;
709 IncludeMarkLength
= 7; (* = INCLUDE *)
713 begin (* ExtractCommentInfo *)
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
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
;
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
];
757 if Value
[Index
] = '''' then begin
758 Info
.Length
:= Index
- StartIndex
- 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 *)
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)
775 Info
:= SubString(Comment
, StartIndex
, Length
- StartIndex
+ 1);
778 end; (* ExtractCommentInfo *)
780 (*---------------------------------------------------------------------------*)
781 (* inserts a node in a binary tree sorted after value. If node
782 is in tree Found returns true. *)
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
794 Node_1
, (* helpvariable to rotate nodes *)
795 Node_2
: BinNodePointer
; (* helpvariable to rotate nodes *)
800 begin (* Value is not in tree, insert *)
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
);
812 if Higher
then (* left bransch has grown higher *)
824 -1: begin (* rebalance *)
827 if Node_1
^.bal
= -1 then
828 begin (* single LL rotation *)
829 Node
^.left
:= Node_1
^.right
;
830 Node_1
^.right
:= Node
;
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
;
843 if Node_2
^.bal
= -1 then
848 if Node_2
^.bal
= 1 then
857 end; (* end case Node^.bal of *)
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
);
866 if Higher
then (* Right bransch has grown higher *)
878 1: begin (* Rebalance *)
879 Node_1
:= Node
^.right
;
881 if Node_1
^.bal
= 1 then
882 begin (* single RR rotation *)
883 Node
^.right
:= Node_1
^.left
;
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
;
896 if Node_2
^.bal
= 1 then
901 if Node_2
^.bal
= -1 then
910 end; (* end case Node^.bal of *)
913 begin (* New value is equal to actual value *)
918 end; (* end INSERT_TREE_NODE *)
920 function GetNameList
; (* : BinNodePointer;*)
922 GetNameList
:= NameList
;
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
;
933 AvailNameList
:= NodeP
;
936 end; (* DisposeANameList *)
938 procedure DisposeNameList
;
940 DisposeANameList(NameList
);
943 function GetNewNameListNode
;(*(
944 var Name : NameString) : BinNodePointer;*)
946 NodeP
: BinNodePointer
;
947 begin (* GetNewNameListNode *)
948 if AvailNameList
= nil then begin
959 NodeP
:= AvailNameList
;
960 AvailNameList
:= NodeP
^.Left
;
967 GetNewNameListNode
:= NodeP
;
968 end; (* GetNewNameListNode *)
970 (*---------------------------------------------------------------------------*)
972 function insertname
;(*(
974 var Found : boolean) : NameStringPointer;*)
977 NodeP
: BinNodePointer
;
978 FoundNode
: BinNodePointer
;
979 begin (* insertname *)
980 NodeP
:= GetNewNameListNode(Name
);
982 INSERT_TREE_NODE(NodeP
, NameList
, FoundNode
, Found
, Higher
);
983 insertname
:= FoundNode
^.NameP
;
985 DisposeANameList(NodeP
);
986 end; (* insertname *)
988 procedure InitNameList
;
991 AvailNameList
:= nil;
994 (********************************************************************)
995 (* NameString - Dynamic Memory Allocation *)
996 (********************************************************************)
998 procedure InitNameStringPool
;
1000 GlobalNSPool
.Avail
:= nil;
1001 GlobalNSPool
.Empty
:= nil;
1004 procedure NewNameString
; (* (var NSP: NameStringPointer );*)
1005 (*var Temp: NSPoolP;*)
1008 if GlobalNSPool.Avail=nil then
1011 Temp := GlobalNSPool.Avail;
1012 GlobalNSPool.Avail := Temp^.Next;
1013 Temp^.Next := GlobalNSPool.Empty;
1014 GlobalNSPool.Empty := Temp;
1022 procedure ReleaseNameString
; (* (var NSP: NameStringPointer );*)
1023 (*var Temp: NSPoolP;*)
1025 if NSP
<> nil then begin
1027 if GlobalNSPool.Empty=nil then begin
1029 Temp^.Next := GlobalNSPool.Avail;
1030 GlobalNSPool.Avail := Temp;
1033 Temp := GlobalNSPool.Empty;
1034 GlobalNSPool.Empty := Temp^.Next;
1035 Temp^.Next := GlobalNSPool.Avail;
1036 GlobalNSPool.Avail := Temp;
1045 procedure SDTrefStringToRec (* (
1046 var S : SDTrefString;
1048 var Error : integer) *) ;
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. *)
1057 ErrorFound
, EndFound
: Boolean;
1059 procedure SDTrefSkipSpaces
;
1060 var Found
: Boolean;
1063 while not Found
and (Len
<= S
.Length
) do
1064 if (S
.Value
[Len
] = ' ') or (S
.Value
[Len
] = chr(9)) then
1070 function SDTrefIsEnd
: Boolean;
1072 SDTrefIsEnd
:= false;
1073 if S
.Value
[Len
] = ')' then
1077 if Len
> S
.Length
then
1078 SDTrefIsEnd
:= true;
1082 function SDTrefGetInteger
: integer;
1089 while not Found
and (Temp
.Length
<= NameStringLength
) and
1090 (Len
<= S
.Length
) do
1091 if S
.Value
[Len
] in ['0'..'9'] then
1093 Temp
.Length
:= Temp
.Length
+1;
1094 Temp
.Value
[Temp
.Length
] := S
.Value
[Len
];
1099 if Temp
.Length
> 0 then
1100 SDTrefGetInteger
:= NmStrToInteger(Temp
)
1102 SDTrefGetInteger
:= SDTrefUndefInt
;
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
;
1117 if S
.Length
= 0 then goto 99;
1118 if S
.Value
[1] <> '#' then goto 99;
1120 if S
.Value
[2] <> 'S' then goto 99;
1122 if S
.Value
[3] <> 'D' then goto 99;
1124 if S
.Value
[4] <> 'T' then goto 99;
1126 if S
.Value
[5] <> 'R' then goto 99;
1128 if S
.Value
[6] <> 'E' then goto 99;
1130 if S
.Value
[7] <> 'F' then goto 99;
1132 if S
.Value
[8] <> '(' then goto 99;
1135 if S
.Value
[9] = 'S' then
1138 if S
.Value
[10] <> 'D' then goto 99;
1140 if S
.Value
[11] <> 'L' then goto 99;
1141 Len
:= 12; SDTrefSkipSpaces
;
1142 if Len
> S
.Length
then goto 99;
1145 if S
.Value
[Len
] <> ',' then goto 99;
1146 Len
:= Len
+1; SDTrefSkipSpaces
;
1147 if Len
> S
.Length
then goto 99;
1151 while not EndFound
and (Len
<= S
.Length
) do
1152 if S
.Value
[Len
] in [',', ')', '(', ' ', chr(9)] then
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
];
1160 if Len
> S
.Length
then goto 99;
1163 if Len
> S
.Length
then goto 99;
1166 if S
.Value
[Len
] = '(' then
1168 Len
:= Len
+1; SDTrefSkipSpaces
;
1169 if Len
> S
.Length
then goto 99;
1171 while not EndFound
and (Len
<= S
.Length
) do
1172 if S
.Value
[Len
] in [',', ')', '(', ' ', chr(9)] then
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
];
1180 if Len
> S
.Length
then goto 99;
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;
1188 if SDTrefIsEnd
then begin ErrorFound
:= false; goto 99; end;
1190 if S
.Value
[Len
] <> ',' then goto 99;
1191 Len
:= Len
+1; SDTrefSkipSpaces
;
1192 if Len
> S
.Length
then goto 99;
1195 R
.ObjectId
:= SDTrefGetInteger
;
1197 if Len
> S
.Length
then goto 99;
1199 (* Object_Coordinates *)
1200 if S
.Value
[Len
] = '(' then
1202 Len
:= Len
+1; SDTrefSkipSpaces
;
1203 if Len
> S
.Length
then goto 99;
1204 R
.XCoord
:= SDTrefGetInteger
;
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
;
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;
1217 if SDTrefIsEnd
then begin ErrorFound
:= false; goto 99; end;
1219 if S
.Value
[Len
] <> ',' then goto 99;
1220 Len
:= Len
+1; SDTrefSkipSpaces
;
1221 if Len
> S
.Length
then goto 99;
1224 R
.LineNumber
:= SDTrefGetInteger
;
1226 if Len
> S
.Length
then goto 99;
1227 if SDTrefIsEnd
then begin ErrorFound
:= false; goto 99; end;
1229 if S
.Value
[Len
] <> ',' then goto 99;
1230 Len
:= Len
+1; SDTrefSkipSpaces
;
1231 if Len
> S
.Length
then goto 99;
1234 R
.Column
:= SDTrefGetInteger
;
1236 if Len
> S
.Length
then goto 99;
1237 if SDTrefIsEnd
then ErrorFound
:= false;
1240 else if S
.Value
[9] = 'T' then
1244 if S
.Value
[10] <> 'E' then goto 99;
1246 if S
.Value
[11] <> 'X' then goto 99;
1248 if S
.Value
[12] <> 'T' then goto 99;
1249 Len
:= 13; SDTrefSkipSpaces
;
1250 if Len
> S
.Length
then goto 99;
1253 if S
.Value
[Len
] <> ',' then goto 99;
1254 Len
:= Len
+1; SDTrefSkipSpaces
;
1255 if Len
> S
.Length
then goto 99;
1259 while not EndFound
and (Len
<= S
.Length
) do
1260 if S
.Value
[Len
] in [',', ')', '(', ' ', chr(9)] then
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
];
1268 if Len
> S
.Length
then goto 99;
1271 if Len
> S
.Length
then goto 99;
1272 if SDTrefIsEnd
then begin ErrorFound
:= false; goto 99; end;
1274 if S
.Value
[Len
] <> ',' then goto 99;
1275 Len
:= Len
+1; SDTrefSkipSpaces
;
1276 if Len
> S
.Length
then goto 99;
1279 R
.LineNumber
:= SDTrefGetInteger
;
1281 if Len
> S
.Length
then goto 99;
1282 if SDTrefIsEnd
then begin ErrorFound
:= false; goto 99; end;
1284 if S
.Value
[Len
] <> ',' then goto 99;
1285 Len
:= Len
+1; SDTrefSkipSpaces
;
1286 if Len
> S
.Length
then goto 99;
1289 R
.Column
:= SDTrefGetInteger
;
1291 if Len
> S
.Length
then goto 99;
1292 if SDTrefIsEnd
then ErrorFound
:= false;
1303 procedure SDTrefRecToString (* (
1305 var S : SDTrefString) *) ;
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 *)
1326 Temp
.Value
[1] := 'S';
1327 Temp
.Value
[2] := 'D';
1328 Temp
.Value
[3] := 'L';
1329 Temp
.Value
[4] := ',';
1331 S
:= Concatenatenamestrings(S
, Temp
);
1334 for I
:= 1 to R
.FileName
.Length
do
1337 if Len
> SDTrefStringLength
then goto 99;
1338 S
.Value
[Len
] := R
.FileName
.Value
[I
];
1342 if R
.PageName
.Length
> 0 then
1345 if Len
> SDTrefStringLength
then goto 99;
1346 S
.Value
[Len
] := '(';
1347 for I
:= 1 to R
.PageName
.Length
do
1350 if Len
> SDTrefStringLength
then goto 99;
1351 S
.Value
[Len
] := R
.PageName
.Value
[I
];
1354 if Len
> SDTrefStringLength
then goto 99;
1355 S
.Value
[Len
] := ')';
1359 if R
.ObjectId
<> SDTrefUndefInt
then
1362 if Len
> SDTrefStringLength
then goto 99;
1363 S
.Value
[Len
] := ',';
1364 Temp
:= integertonmstr(R
.ObjectId
);
1365 for I
:= 1 to Temp
.Length
do
1368 if Len
> SDTrefStringLength
then goto 99;
1369 S
.Value
[Len
] := Temp
.Value
[I
];
1373 (* Object_Coordinates *)
1374 if R
.XCoord
<> SDTrefUndefInt
then
1377 if Len
> SDTrefStringLength
then goto 99;
1378 S
.Value
[Len
] := '(';
1379 Temp
:= integertonmstr(R
.XCoord
);
1380 for I
:= 1 to Temp
.Length
do
1383 if Len
> SDTrefStringLength
then goto 99;
1384 S
.Value
[Len
] := Temp
.Value
[I
];
1387 if Len
> SDTrefStringLength
then goto 99;
1388 S
.Value
[Len
] := ',';
1389 Temp
:= integertonmstr(R
.YCoord
);
1390 for I
:= 1 to Temp
.Length
do
1393 if Len
> SDTrefStringLength
then goto 99;
1394 S
.Value
[Len
] := Temp
.Value
[I
];
1397 if Len
> SDTrefStringLength
then goto 99;
1398 S
.Value
[Len
] := ')';
1402 if R
.LineNumber
<> SDTrefUndefInt
then
1405 if Len
> SDTrefStringLength
then goto 99;
1406 S
.Value
[Len
] := ',';
1407 Temp
:= integertonmstr(R
.LineNumber
);
1408 for I
:= 1 to Temp
.Length
do
1411 if Len
> SDTrefStringLength
then goto 99;
1412 S
.Value
[Len
] := Temp
.Value
[I
];
1417 if R
.Column
<> SDTrefUndefInt
then
1420 if Len
> SDTrefStringLength
then goto 99;
1421 S
.Value
[Len
] := ',';
1422 Temp
:= integertonmstr(R
.Column
);
1423 for I
:= 1 to Temp
.Length
do
1426 if Len
> SDTrefStringLength
then goto 99;
1427 S
.Value
[Len
] := Temp
.Value
[I
];
1432 if Len
> SDTrefStringLength
then goto 99;
1433 S
.Value
[Len
] := ')';
1439 Temp
.Value
[1] := 'T';
1440 Temp
.Value
[2] := 'E';
1441 Temp
.Value
[3] := 'X';
1442 Temp
.Value
[4] := 'T';
1443 Temp
.Value
[5] := ',';
1445 S
:= Concatenatenamestrings(S
, Temp
);
1448 for I
:= 1 to R
.FileName
.Length
do
1451 if Len
> SDTrefStringLength
then goto 99;
1452 S
.Value
[Len
] := R
.FileName
.Value
[I
];
1456 if R
.LineNumber
<> SDTrefUndefInt
then
1459 if Len
> SDTrefStringLength
then goto 99;
1460 S
.Value
[Len
] := ',';
1461 Temp
:= integertonmstr(R
.LineNumber
);
1462 for I
:= 1 to Temp
.Length
do
1465 if Len
> SDTrefStringLength
then goto 99;
1466 S
.Value
[Len
] := Temp
.Value
[I
];
1471 if R
.Column
<> SDTrefUndefInt
then
1474 if Len
> SDTrefStringLength
then goto 99;
1475 S
.Value
[Len
] := ',';
1476 Temp
:= integertonmstr(R
.Column
);
1477 for I
:= 1 to Temp
.Length
do
1480 if Len
> SDTrefStringLength
then goto 99;
1481 S
.Value
[Len
] := Temp
.Value
[I
];
1486 if Len
> SDTrefStringLength
then goto 99;
1487 S
.Value
[Len
] := ')';
1491 if Len
> SDTrefStringLength
then
1497 function NmStrToErrStr
;(*(
1498 NmStr : NameString) : ErrorString;*)
1500 ErrStr
: ErrorString
;
1503 for i
:= 1 to NmStr
.Length
do
1504 ErrStr
.Value
[i
] := NmStr
.Value
[i
];
1505 ErrStr
.Length
:= NmStr
.Length
;
1506 NmStrToErrStr
:= ErrStr
;
1509 function ErrStrToNmStr
;(*(
1510 ErrStr : ErrorString) : NameString;*)
1516 if ErrStr
.Length
< NameStringLength
then
1519 n
:= NameStringLength
;
1521 NmStr
.Value
[i
] := ErrStr
.Value
[i
];
1523 ErrStrToNmStr
:= NmStr
;
1526 (*------------------------------------------------------------------*)
1528 (*------------------------------------------------------------------*)
1529 function GetTextRef
;(*(
1532 Col : integer) : NameString;*)
1536 begin(* GetTextRef *)
1537 Ref
.IsSDTGR
:= false;
1538 Ref
.FileName
:= FNm
;
1539 Ref
.LineNumber
:= Ln
;
1541 SDTrefRecToString(Ref
, S
);
1543 end; (* GetTextRef *)