(C) Jasper Neumann, June of 2003
Simulation of CLU iterators for Delphi and Kylix (16 and 32 bit)
*** Motivation
Delegation of extensive loop constructions as one procedure call.
One should not be forced to repeat them again and again.
Simulation of CLU iterators.
*** Application
Loop through containers (lists, trees, parameters, directories, registry, etc.).
"Frame routines", e.g. for locking purposes.
*** Semantic
Principely the iterator (iterator_proc) is called, which on its part calls the
loop body (iterator_body) on each yield.
The loop body and its scope are transferred as hidden parameters
(return_addr, ebp).
To let this work correctly some tricks are necessary resulting in some
restrictions, but they can be circumvented by the formalisms decsribed below.
The iterator communicates with the loop body via reference parameters.
*** Application of an iterator
1
2 iterator_proc(...);
3 iterate; while iterating do begin
4 iterator_body;
5 end;
*** Definition of an iterator
6
7 procedure iterator_proc(...);
8 var
9 i_base: t_iterator_base;
10 procedure sub_iter;
11 begin
12 ...
13 yield(i_base);
14 ...
15 end;
16 begin
17 iterator_start(i_base);
18 sub_iter;
19 iterator_stop(i_base);
20 end;
21
*** Aborting an iterator
22
23 try
24 iterator_proc(...);
25 iterate; while iterating do begin
26 ...
27 if necessary then
28 raise ...; (* signal break via exception *)
29 ...
30 end;
31 except
32 ... (* catch the break exception *)
33 end;
34
It makes sense to circumvent the try..finally construction by setting a
boolean reference variable _break to true:
35
36 iterator_proc(...,_break);
37 iterate; while iterating do begin
38 ...
39 if necessary then
40 _break:=true
41 else begin
42 ...
43 end;
44 end;
45
46 procedure iterator_proc(...; var _break:boolean);
47 var
48 i_base: t_iterator_base;
49 procedure sub_iter;
50 begin
51 _break:=false;
52 ...
53 yield(i_base);
54 if _break then
55 EXIT;
56 ...
57 end;
58 begin
59 iterator_start(i_base);
60 sub_iter;
61 iterator_stop(i_base);
62 end;
63
*** Remarks
1. The iterator (iterator_proc) must be a procedure or method.
2. Calling convention of the iterator <> cdecl.
3. Iterators must be FAR (this is always the case in 32-bit-code).
4. It is forbidden to have parameters that must be copied by preamble of the
iterator (string/set/object/record/array), they must therefore be transferred
via reference (const) (ebx, esi, edi must be preserved by the iterator
preamble).
5. Exceptions from the loop body must not be ignored by the iterator, because
otherwise the register variables of the loop body (and the surrounding code)
will possibly be destroyed.
6. An iterator loop may only be aborted with an exception but never with
GOTO/EXIT/BREAK.
7. Constant referenz parameter which will be read after yield by the iterator
(e.g. strings) should be copied first into local copies by sub_iter because
they might become invalid after the yield (e.g. when calling with string
expressions).
8. The iterator should obey strongly the formalism mentioned above, that means
all actions should occur in sub_iter.
9. The compiler option $w+ (Stack frames on) should be set globally
(the addressing in the loop body must not be esc relative).
- You may apply iterators recursively, i.e. you may nest iterator loops.
sub_iter may call itself directly or indirectly.
Iterators may use iterators; the yield may be executed in other procedures.
- The traditional way (e.g. C++ STL) uses an object with up to 6 methods
(create, init, eof, value, step, free); in contrast to this with our solution
you cannot run two iterators simultaneously (in one thread) to e.g. compare
two lists but it is much easier to make the program correct.
No space on the heap is necessary.
- Since Delphi does not support local procedures (iterator_body) as parameters
at all or incompletely (no scope), this implementation could not be chosen.
By the way: In qgrids.pas the method TSparsePointerArray.ForAll and in
TVision's TCollection.ForEach and TCollection.FirstThat such iterators were
already simulated, however there were severe limitations in application.
*** Example (result: '1 2 3 4 7 8 9 10 ')
64
65 (*$w+*)
66 uses
67 iterator;
68
69 type
70 tn_set=byte;
71 tsn_set=set of tn_set;
72
73 procedure for_in(var i:byte; const s:tsn_set); FAR; (* => 3., 4. *)
74 var
75 i_base: t_iterator_base;
76 procedure sub_iter;
77 var
78 j: tn_set;
79 ss: tsn_set;
80 begin
81 ss:=s; (* Local copy, => 7. *)
82 for j:=0 to 255 do begin
83 if j in ss then begin
84 i:=j;
85 YIELD(i_base);
86 end;
87 end;
88 end;
89 begin (* for_in *)
90 iterator_start(i_base);
91 sub_iter;
92 iterator_stop(i_base);
93 end;
94
95 var
96 q: tn_set;
97 begin
98 for_in(q, [1..3, 7..10]);
99 ITERATE; while ITERATING do begin
100 write(q,' ');
101 end;
102 end.
*** References
http://www.home.unix-ag.org/tjabo/ruby/uguide/uguide08.html
http://webster.cs.ucr.edu/Page_asm/ArtofAssembly/CH12/CH12-6.html
c't 1994/10, page 244
*** License
Hereby I grant these programming sniplets to the public domain.
Of course I cannot take any responsibility for it.
If need be, send me hints, questions, or remarks.
Please send me a nice postcard if you could make any use of it.
Thanks a lot!
_-jane-_@web.de
Jasper Neumann
Schoenauer Friede 78
D-52072 Aachen
Germany
****************************** CODE MAIN UNIT **********************
103
104 (*$ifdef ver80 *)
105 (*$define _16 *) (* 16 bit Delphi *)
106 (*$else *)
107 (*$define _32 *) (* 32 bit Delphi *)
108 (*$w+*) (* Generate stack frame (necessary for iterators) *)
109 (*$endif *)
110
111 (* (C) Jasper Neumann *)
112 (* Simulation of iterators as in the programming language CLU *)
113
114 unit iterator;
115
116 interface
117
118 (*$ifdef _16 *)
119 type
120 t_iterator_base=record
121 _bp: word;
122 _call: pointer;
123 end;
124 (*$else *)
125 type
126 t_iterator_base=record
127 _ebx: longint;
128 _esi: longint;
129 _edi: longint;
130 _ebp: longint;
131 _call: pointer;
132 end;
133 (*$endif *)
134
135 procedure iterate;
136 (*$ifdef _16 *)
137 inline(
138 $b0/$00 (* mov al,false *)
139 /$eb/$03 (* jmp short goon *)
140 );
141 (*$endif *)
142
143 function iterating:boolean;
144 (*$ifdef _16 *)
145 inline(
146 $cb (* retf *)
147 /$b0/$01 (* loop: mov al,true *)
148 ); (* goon: *)
149 (*$endif *)
150 procedure iterator_start(var base:t_iterator_base);
151
152 (*$ifdef _16 *)
153 inline(
154 $5F (* pop di *)
155 /$07 (* pop es *)
156 /$8b/$5E/$00 (* mov bx,[bp] // org bp *)
157 /$26/$89/$1D (* mov es:[di+t_iterator_base._bp],bx *)
158 /$8b/$5E/$02 (* mov bx,[bp+02] // ret-adr ofs *)
159 /$83/$C3/$05 (* add bx,5 // Einspringpunkt *)
160 /$26/$89/$5D/$02 (* mov word ptr es:[di+t_iterator_base._call],bx *)
161 /$8b/$5E/$04 (* mov bx,[bp+04] // ret-adr seg *)
162 /$26/$89/$5D/$04 (* mov word ptr es:[di+t_iterator_base._call+2],bx *)
163 );
164 (*$endif *)
165
166 procedure iterator_stop(const base:t_iterator_base);
167 (*$ifdef _16 *)
168 inline(
169 (* kill argument *)
170 $5B (* pop bx *)
171 /$07 (* pop es *)
172 );
173 (*$endif *)
174
175 procedure YIELD(const base:t_iterator_base);
176 (*$ifdef _16 *)
177 inline(
178 $5B (* pop bx *)
179 /$07 (* pop es *)
180 /$55 (* push bp *)
181 /$26/$8b/$2f (* mov bp,es:[bx+t_iterator_base._bp] *)
182 /$26/$ff/$5f/$02 (* call far es:[bx+t_iterator_base._call] *)
183 /$5D (* pop bp *)
184 );
185 (*$endif *)
186
187 implementation
188
189 (*$ifdef _32 *)
190
191 const
192 mask_near_jmp=$fffc0000; (* mask for maximum near jmp *)
193
194 procedure raise_tch(p:pointer);
195 begin
196 asm int 3 end;
197 (* This must not happen! *)
198 (* Raise an exception here if you want to: Illegal code at p *)
199 end;
200
201 procedure iterate;
202 { assembler; }
203 asm
204 pop eax (* Fetch return address *)
205 mov dl,[eax]
206 mov ecx,[eax+1]
207 cmp dl,$eb (* Jmp short? *)
208 je @@short
209 cmp dl,$e9 (* Jmp near? *)
210 je @@near
211 cmp dl,$e8 (* Call iterating? *)
212 je @@call
213 cmp dl,$cc (* Breakpoint? *)
214 je @@break
215 call RAISE_TCH (* No? This MUST NOT happen! *)
216
217 @@sleuth_err:
218 call RAISE_TCH
219
220 @@break: (* A breakpoint detected... *)
221 int 3 (* ...let us step through. *)
222 mov edx,ecx
223 add edx,eax
224 cmp edx,offset iterating-5
225 je @@call1 (* Probably call *)
226 mov edx,ecx
227 and edx,mask_near_jmp
228 jz @@near (* Probably near *)
229 jmp @@short (* No? Ought to be short *)
230
231 @@call:
232 mov edx,ecx
233 add edx,eax
234 cmp edx,offset iterating-5
235 je @@call1
236 call RAISE_TCH (* No JMP? This MUST NOT happen! *)
237 @@call1:
238 add eax,5 (* Skip the JMP near *)
239 jmp @@go_on
240
241 @@near:
242 lea eax,[eax+ecx+5+5] (* Skip the JMP near and the call of iterate *)
243 jmp @@go_on
244
245 @@short:
246 movsx ecx,cl
247 lea eax,[eax+ecx+2+5] (* Skip the JMP short and the call of iterate *)
248 @@go_on:
249
250 (* Sleuth fixup :*)
251 cmp byte ptr [eax-5],$9c (* Sleuth? *)
252 jne @@normal
253 cmp word ptr [eax-5+1],$be60
254 jne @@sleuth_err
255 cmp word ptr [eax-5+7],$15ff
256 jne @@sleuth_err
257 cmp word ptr [eax-5+13],$9D61
258 jne @@sleuth_err
259 add eax,15
260 @@normal:
261
262 push eax
263 mov al,false (* Yield false to while *)
264 end;
265
266 function iterating:boolean;
267 { assembler; }
268 asm
269 pop eax (* Pop the return address and return to YIELD *)
270 end;
271
272 procedure iterator_start(var base:t_iterator_base);
273 (* eax: @base *)
274 asm
275 mov edx,[ebp] (* Fetch saved ebp of iterator *)
276 mov [eax].t_iterator_base._ebx,ebx
277 mov [eax].t_iterator_base._esi,esi
278 mov [eax].t_iterator_base._edi,edi
279 mov [eax].t_iterator_base._ebp,edx
280 mov edx,[ebp+4] (* Fetch return address of iterator *)
281 (* Stack frames are needed for the iterator ($w+ !) *)
282 (* Sleuth fixup :*)
283 cmp byte ptr [edx],$9c (* Sleuth? *)
284 jne @@normal
285 cmp word ptr [edx+1],$be60
286 jne @@sleuth_err
287 cmp word ptr [edx+7],$15ff
288 jne @@sleuth_err
289 cmp word ptr [edx+13],$9D61
290 jne @@sleuth_err
291 add edx,15
292
293 @@normal:
294 add edx,5 (* Skip the call of iterate *)
295 mov cl,[edx]
296 cmp cl,$eb (* Jmp short? *)
297 je @@short
298 cmp cl,$e9 (* Jmp dword? *)
299 je @@near
300 cmp cl,$e8 (* Call iterating? *)
301 je @@call
302 cmp cl,$cc (* Breakpoint? *)
303 je @@break
304 mov eax,edx
305 call RAISE_TCH (* No? This MUST NOT happen! *)
306
307 @@sleuth_err:
308 mov eax,edx
309 call RAISE_TCH
310
311 @@break: (* A breakpoint detected... *)
312 int 3 (* ...let us step through. *)
313 mov ecx,[edx+1]
314 add ecx,edx
315 cmp ecx,offset iterating-5
316 je @@go_on (* Probably call *)
317 mov ecx,[edx+1]
318 and ecx,mask_near_jmp
319 jz @@near (* Probably near *)
320 jmp @@short (* No? Ought to be short *)
321
322 @@call:
323 mov ecx,[edx+1]
324 add ecx,edx
325 cmp ecx,offset iterating-5
326 je @@go_on
327 mov eax,edx
328 call RAISE_TCH (* No JMP? This MUST NOT happen! *)
329
330 @@near:
331 add edx,3 (* Skip the JMP near (+2) *)
332 @@short:
333 add edx,2 (* Skip the JMP short *)
334 @@go_on:
335 mov [eax].t_iterator_base._call,edx
336 end;
337
338 procedure iterator_stop(const base:t_iterator_base);
339 (* eax: @base *)
340 asm
341 mov ebx,[eax].t_iterator_base._ebx
342 mov esi,[eax].t_iterator_base._esi
343 mov edi,[eax].t_iterator_base._edi
344 { mov ebp,[eax].t_iterator_base._ebp }
345 end;
346
347 procedure YIELD(const base:t_iterator_base);
348 (* eax: @base *)
349 asm
350 push ebx
351 push esi
352 push edi
353 push ebp
354 mov ebx,[eax].t_iterator_base._ebx
355 mov esi,[eax].t_iterator_base._esi
356 mov edi,[eax].t_iterator_base._edi
357 mov ebp,[eax].t_iterator_base._ebp
358 push eax
359 call [eax].t_iterator_base._call
360 pop eax
361 mov [eax].t_iterator_base._edi,edi
362 mov [eax].t_iterator_base._esi,esi
363 mov [eax].t_iterator_base._ebx,ebx
364 pop ebp
365 pop edi
366 pop esi
367 pop ebx
368 end;
369
370 (*$endif *)
371
372 end.
************************* Sample Program ******************************
373
374 (*$ifdef ver80 *)
375 (*$define _16 *) (* 16 bit Delphi *)
376 (*$else *)
377 (*$define _32 *) (* 32 bit Delphi *)
378 (*$w+*) (* Generate stack frame (necessary for iterators) *)
379 (*$endif *)
380
381 (* (C) Jasper Neumann *)
382
383 program itertest;
384 (* Example: Meet all members of a set (resulting in 1 2 3 7 8 9 10 ) *)
385
386 uses
387 iterator;
388
389 type
390 tn_set=byte;
391 tsn_set=set of tn_set;
392
393 procedure for_in(var i:tn_set; const s:tsn_set); FAR;
394 var
395 i_base: t_iterator_base; (* No other variables here *)
396
397 procedure sub_iter;
398 (* All the iterator stuff is managed here *)
399 var
400 j: tn_set;
401 ss: tsn_set;
402 begin
403 (* Be sure that all const ref parameters get their local copy *)
404 (* if they are used after YIELD! *)
405 ss:=s;
406 for j:=low(tn_set) to high(tn_set) do begin
407 if j in ss then begin
408 i:=j;
409 YIELD(i_base);
410 end;
411 end;
412 end;
413
414 begin
415 (* Every iterator should look like this; no further action here! *)
416 iterator_start(i_base);
417 sub_iter;
418 iterator_stop(i_base);
419 end;
420
421 var
422 q: tn_set;
423 begin
424 for_in(q, [1..5, 7..10]);
425 ITERATE; while ITERATING do begin
426 SYSTEM.write(q,' ');
427 end;
428 end.
|
