summaryrefslogtreecommitdiff
path: root/Build/source/utils/m-tx/mtx-src/strings.pas
blob: 9f7deabd1839cbee2e8c2d7f37e7b5a21bf4f5a3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
unit strings;   { String handling primitives. }
  { These should be recoded in C instead of using the p2c code. }

interface

procedure scan1 (s: string; p: integer; var n: integer);
  { Read an integer at position p of s }
function startsWith (s1, s2: string): boolean;
function pos1(c: char; s: string): integer;
function posNot (c: char; var s: string): integer;
procedure insertChar (c: char; var s: string; p: integer);
function substr (var s: string; start, count: integer): string;
procedure getNum(line: string; var k: integer);
procedure getTwoNums(var line: string; var k1, k2: integer);
procedure toUpper(var s: string);
procedure delete1 (var s: string; p: integer);
procedure predelete (var s: string; l: integer);
procedure shorten (var s: string; new_length: integer);
function nextWordBound(s: string; trigger: char; p: integer): integer;
  { find end of first word starting with trigger after s[p] }

implementation

procedure scan1 (s: string; p: integer; var n: integer);
  begin  if length(s)<p then
    writeln('scan1: string too short');
      predelete(s,p-1); getNum(s,n);
  end;

function pos1(c: char; s: string): integer;
  begin  pos1:= pos(c, s);  end;

procedure delete1 (var s: string; p: integer);
  begin  if length(s)<p then
    writeln('delete1: string too short');
    delete(s,p,1);
  end;

procedure predelete (var s: string; l: integer);
  begin  if length(s)<l then
    writeln('predelete: string too short');
    delete(s,1,l);
  end;

procedure shorten (var s: string; new_length: integer);
  begin  if length(s)<new_length then
    writeln('shorten: string too short');
    s[0] := char(new_length);
  end;

function posNot(c: char; var s: string): integer;
  var i, l: integer;
begin  l:=length(s);
   for i:=1 to l do if s[i]<>c then
   begin posnot:=i; exit; end;
   posnot:=0;
end;

procedure strval(line: string; var num, p: integer);
  begin  val(line,num,p);  end;

procedure getNum(line: string; var k: integer);
  var code: integer;
begin  strval(line,k,code);
  if code>0 then strval(copy(line,1,code-1),k,code);
end;

procedure getTwoNums(var line: string; var k1, k2: integer);
  var num, code, p: integer;
begin
  strval(line,num,p); strval(copy(line,1,p-1),k1,code);
  strval(copy(line,p+1,255),k2,code);
  if code>0 then strval(copy(line,1,code-1),k2,code);
end;

procedure toUpper (var s: string);
  var i: integer;
begin
  for i:=1 to length(s) do s[i]:=upcase(s[i]);
end;

function startsWith (s1, s2: string): boolean;
  var i, l1, l2: integer;
  begin  l1:=length(s1);  l2:=length(s2);
    startsWith := false;  if l1<l2 then exit;
    for i:=1 to l2 do if s1[i]<>s2[i] then exit;
    startsWith := true;
  end;

procedure insertChar (c: char; var s: string; p: integer);
  begin  if length(s)<p-1 then
    writeln('insertchar: string too short');
    insert(c,s,p);
  end;

function substr (var s: string; start, count: integer): string;
  begin  if length(s)<start+count-1 then
    writeln('insertchar: string too short');
    substr := copy(s,start,count);
  end;

function nextWordBound(s: string; trigger: char; p: integer): integer;
 begin
  repeat p:=p+1 until (p>length(s)) or (s[p]=trigger);
  while (p<length(s)) and (s[p+1]<>' ') do p:=p+1;
  nextWordBound:=p;
end;

end.