-
Notifications
You must be signed in to change notification settings - Fork 1
/
XSTRING.PAS
165 lines (108 loc) · 3.71 KB
/
XSTRING.PAS
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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
{ XSTRING.PAS
Description:
An "extended string" suitable for Archetype. Uses reference counting
and copy-on-write semantics for efficiency; extends itself if necessary,
up to the range of a two-byte unsigned integer.
}
unit xarray;
interface
uses misc;
type
ref_type =
record
references : integer;
allocation : integer;
data : pointer
end;
xstring_type =
record
length : integer; { both in units of bytes }
reference : ^ref_type
end;
{ Procedures and Functions }
procedure new_xstring(var the_xstring: xstring_type);
procedure dispose_xstring(var the_xstring: xstring_type);
procedure concat_xstring(var the_xstring: xstring_type;
var extra_xstring: xstring_type;
var out_xstring: xstring_type);
procedure copy_xstring(var destination: xstring_type;
var source: xstring_type);
procedure assign_xstring(var destination: xstring_type;
var source: xstring_type);
{ Special operations for efficient Archetype access }
procedure leftfrom_xstring(var the_xstring: xstring_type;
leftfrom: integer;
var output_xstring: xstring_type);
procedure rightfrom_xstring(var the_xstring: xstring_type;
rightfrom: integer;
var output_xstring: xstring_type);
function within_xstring(var the_xstring: xstring_type;
var substring: xstring_type): integer;
{ Interfacing with regular strings }
procedure import_string(var the_xstring: xstring_type; strdata: string);
procedure export_string(var the_xstring: xstring_type; var strdata: string); var strdata: string);
procedure export_substring(var the_xstring: xstring_type;
start, length: integer;
var strdata: string);
implementation
{ Constants having to do with memory chunk size, to prevent heap
fragmentation. Chosen to match a DOS memory paragraph. }
const
CHUNK_SIZE = 15;
CHUNK_MASK = $FFF0;
type byte_mask = array[1..65536] of character;
{ strmem_alloc
Description:
Allocates memory on a nice paragraph boundary.
}
function strmem_alloc(size: integer; var newsize): pointer;
var
p: pointer;
begin
newsize = (size + CHUNK_SIZE) and CHUNK_MASK;
GetMem(p, newsize);
strmem_alloc := p
end;
procedure strmem_free(p: pointer; size: integer);
begin
FreeMem(p, size)
end;
{ new_xstring
Description:
The constructor.
Arguments:
the_xstring (OUT) -- the array to be constructed
}
procedure new_xstring(var the_xstring: xstring_type);
begin
with the_xstring do begin
length := 0;
new(reference);
with (reference^) do begin
references := 0;
allocation := 0;
data := nil
end
end
end; { new_xstring }
{ dispose_xstring
Description:
The destructor for the class. Calls to this procedure must be followed
by a call to new_xstring in order to use the same xstring again.
Arguments:
the_xstring (IN/OUT) -- the xstring whose memory needs to be deallocated.
}
procedure dispose_xstring(var the_xstring: xstring_type);
begin
with the_xstring do begin
with reference^ do begin
dec(references);
if (references = 0) then
strmem_free(data, allocation)
end;
dispose(reference);
reference := nil;
length := 0
end
end; { dispose_xstring }
end. { unit xstring }