Mega Code Archive
Simulation of clu iterators
<![CDATA[
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
iterator_proc(...);
iterate; while iterating do begin
iterator_body;
end;
*** Definition of an iterator
procedure iterator_proc(...);
var
i_base: t_iterator_base;
procedure sub_iter;
begin
...
yield(i_base);
...
end;
begin
iterator_start(i_base);
sub_iter;
iterator_stop(i_base);
end;
*** Aborting an iterator
try
iterator_proc(...);
iterate; while iterating do begin
...
if necessary then
raise ...; (* signal break via exception *)
...
end;
except
... (* catch the break exception *)
end;
It makes sense to circumvent the try..finally construction by setting a
boolean reference variable _break to true:
iterator_proc(...,_break);
iterate; while iterating do begin
...
if necessary then
_break:=true
else begin
...
end;
end;
procedure iterator_proc(...; var _break:boolean);
var
i_base: t_iterator_base;
procedure sub_iter;
begin
_break:=false;
...
yield(i_base);
if _break then
EXIT;
...
end;
begin
iterator_start(i_base);
sub_iter;
iterator_stop(i_base);
end;
*** 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 ')
(*$w+*)
uses
iterator;
type
tn_set=byte;
tsn_set=set of tn_set;
procedure for_in(var i:byte; const s:tsn_set); FAR; (* => 3., 4. *)
var
i_base: t_iterator_base;
procedure sub_iter;
var
j: tn_set;
ss: tsn_set;
begin
ss:=s; (* Local copy, => 7. *)
for j:=0 to 255 do begin
if j in ss then begin
i:=j;
YIELD(i_base);
end;
end;
end;
begin (* for_in *)
iterator_start(i_base);
sub_iter;
iterator_stop(i_base);
end;
var
q: tn_set;
begin
for_in(q, [1..3, 7..10]);
ITERATE; while ITERATING do begin
write(q,' ');
end;
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 **********************
(*$ifdef ver80 *)
(*$define _16 *) (* 16 bit Delphi *)
(*$else *)
(*$define _32 *) (* 32 bit Delphi *)
(*$w+*) (* Generate stack frame (necessary for iterators) *)
(*$endif *)
(* (C) Jasper Neumann *)
(* Simulation of iterators as in the programming language CLU *)
unit iterator;
interface
(*$ifdef _16 *)
type
t_iterator_base=record
_bp: word;
_call: pointer;
end;
(*$else *)
type
t_iterator_base=record
_ebx: longint;
_esi: longint;
_edi: longint;
_ebp: longint;
_call: pointer;
end;
(*$endif *)
procedure iterate;
(*$ifdef _16 *)
inline(
$b0/$00 (* mov al,false *)
/$eb/$03 (* jmp short goon *)
);
(*$endif *)
function iterating:boolean;
(*$ifdef _16 *)
inline(
$cb (* retf *)
/$b0/$01 (* loop: mov al,true *)
); (* goon: *)
(*$endif *)
procedure iterator_start(var base:t_iterator_base);
(*$ifdef _16 *)
inline(
$5F (* pop di *)
/$07 (* pop es *)
/$8b/$5E/$00 (* mov bx,[bp] // org bp *)
/$26/$89/$1D (* mov es:[di+t_iterator_base._bp],bx *)
/$8b/$5E/$02 (* mov bx,[bp+02] // ret-adr ofs *)
/$83/$C3/$05 (* add bx,5 // Einspringpunkt *)
/$26/$89/$5D/$02 (* mov word ptr es:[di+t_iterator_base._call],bx *)
/$8b/$5E/$04 (* mov bx,[bp+04] // ret-adr seg *)
/$26/$89/$5D/$04 (* mov word ptr es:[di+t_iterator_base._call+2],bx *)
);
(*$endif *)
procedure iterator_stop(const base:t_iterator_base);
(*$ifdef _16 *)
inline(
(* kill argument *)
$5B (* pop bx *)
/$07 (* pop es *)
);
(*$endif *)
procedure YIELD(const base:t_iterator_base);
(*$ifdef _16 *)
inline(
$5B (* pop bx *)
/$07 (* pop es *)
/$55 (* push bp *)
/$26/$8b/$2f (* mov bp,es:[bx+t_iterator_base._bp] *)
/$26/$ff/$5f/$02 (* call far es:[bx+t_iterator_base._call] *)
/$5D (* pop bp *)
);
(*$endif *)
implementation
(*$ifdef _32 *)
const
mask_near_jmp=$fffc0000; (* mask for maximum near jmp *)
procedure raise_tch(p:pointer);
begin
asm int 3 end;
(* This must not happen! *)
(* Raise an exception here if you want to: Illegal code at p *)
end;
procedure iterate;
{ assembler; }
asm
pop eax (* Fetch return address *)
mov dl,[eax]
mov ecx,[eax+1]
cmp dl,$eb (* Jmp short? *)
je @@short
cmp dl,$e9 (* Jmp near? *)
je @@near
cmp dl,$e8 (* Call iterating? *)
je @@call
cmp dl,$cc (* Breakpoint? *)
je @@break
call RAISE_TCH (* No? This MUST NOT happen! *)
@@sleuth_err:
call RAISE_TCH
@@break: (* A breakpoint detected... *)
int 3 (* ...let us step through. *)
mov edx,ecx
add edx,eax
cmp edx,offset iterating-5
je @@call1 (* Probably call *)
mov edx,ecx
and edx,mask_near_jmp
jz @@near (* Probably near *)
jmp @@short (* No? Ought to be short *)
@@call:
mov edx,ecx
add edx,eax
cmp edx,offset iterating-5
je @@call1
call RAISE_TCH (* No JMP? This MUST NOT happen! *)
@@call1:
add eax,5 (* Skip the JMP near *)
jmp @@go_on
@@near:
lea eax,[eax+ecx+5+5] (* Skip the JMP near and the call of iterate *)
jmp @@go_on
@@short:
movsx ecx,cl
lea eax,[eax+ecx+2+5] (* Skip the JMP short and the call of iterate *)
@@go_on:
(* Sleuth fixup :*)
cmp byte ptr [eax-5],$9c (* Sleuth? *)
jne @@normal
cmp word ptr [eax-5+1],$be60
jne @@sleuth_err
cmp word ptr [eax-5+7],$15ff
jne @@sleuth_err
cmp word ptr [eax-5+13],$9D61
jne @@sleuth_err
add eax,15
@@normal:
push eax
mov al,false (* Yield false to while *)
end;
function iterating:boolean;
{ assembler; }
asm
pop eax (* Pop the return address and return to YIELD *)
end;
procedure iterator_start(var base:t_iterator_base);
(* eax: @base *)
asm
mov edx,[ebp] (* Fetch saved ebp of iterator *)
mov [eax].t_iterator_base._ebx,ebx
mov [eax].t_iterator_base._esi,esi
mov [eax].t_iterator_base._edi,edi
mov [eax].t_iterator_base._ebp,edx
mov edx,[ebp+4] (* Fetch return address of iterator *)
(* Stack frames are needed for the iterator ($w+ !) *)
(* Sleuth fixup :*)
cmp byte ptr [edx],$9c (* Sleuth? *)
jne @@normal
cmp word ptr [edx+1],$be60
jne @@sleuth_err
cmp word ptr [edx+7],$15ff
jne @@sleuth_err
cmp word ptr [edx+13],$9D61
jne @@sleuth_err
add edx,15
@@normal:
add edx,5 (* Skip the call of iterate *)
mov cl,[edx]
cmp cl,$eb (* Jmp short? *)
je @@short
cmp cl,$e9 (* Jmp dword? *)
je @@near
cmp cl,$e8 (* Call iterating? *)
je @@call
cmp cl,$cc (* Breakpoint? *)
je @@break
mov eax,edx
call RAISE_TCH (* No? This MUST NOT happen! *)
@@sleuth_err:
mov eax,edx
call RAISE_TCH
@@break: (* A breakpoint detected... *)
int 3 (* ...let us step through. *)
mov ecx,[edx+1]
add ecx,edx
cmp ecx,offset iterating-5
je @@go_on (* Probably call *)
mov ecx,[edx+1]
and ecx,mask_near_jmp
jz @@near (* Probably near *)
jmp @@short (* No? Ought to be short *)
@@call:
mov ecx,[edx+1]
add ecx,edx
cmp ecx,offset iterating-5
je @@go_on
mov eax,edx
call RAISE_TCH (* No JMP? This MUST NOT happen! *)
@@near:
add edx,3 (* Skip the JMP near (+2) *)
@@short:
add edx,2 (* Skip the JMP short *)
@@go_on:
mov [eax].t_iterator_base._call,edx
end;
procedure iterator_stop(const base:t_iterator_base);
(* eax: @base *)
asm
mov ebx,[eax].t_iterator_base._ebx
mov esi,[eax].t_iterator_base._esi
mov edi,[eax].t_iterator_base._edi
{ mov ebp,[eax].t_iterator_base._ebp }
end;
procedure YIELD(const base:t_iterator_base);
(* eax: @base *)
asm
push ebx
push esi
push edi
push ebp
mov ebx,[eax].t_iterator_base._ebx
mov esi,[eax].t_iterator_base._esi
mov edi,[eax].t_iterator_base._edi
mov ebp,[eax].t_iterator_base._ebp
push eax
call [eax].t_iterator_base._call
pop eax
mov [eax].t_iterator_base._edi,edi
mov [eax].t_iterator_base._esi,esi
mov [eax].t_iterator_base._ebx,ebx
pop ebp
pop edi
pop esi
pop ebx
end;
(*$endif *)
end.
************************* Sample Program ******************************
(*$ifdef ver80 *)
(*$define _16 *) (* 16 bit Delphi *)
(*$else *)
(*$define _32 *) (* 32 bit Delphi *)
(*$w+*) (* Generate stack frame (necessary for iterators) *)
(*$endif *)
(* (C) Jasper Neumann *)
program itertest;
(* Example: Meet all members of a set (resulting in 1 2 3 7 8 9 10 ) *)
uses
iterator;
type
tn_set=byte;
tsn_set=set of tn_set;
procedure for_in(var i:tn_set; const s:tsn_set); FAR;
var
i_base: t_iterator_base; (* No other variables here *)
procedure sub_iter;
(* All the iterator stuff is managed here *)
var
j: tn_set;
ss: tsn_set;
begin
(* Be sure that all const ref parameters get their local copy *)
(* if they are used after YIELD! *)
ss:=s;
for j:=low(tn_set) to high(tn_set) do begin
if j in ss then begin
i:=j;
YIELD(i_base);
end;
end;
end;
begin
(* Every iterator should look like this; no further action here! *)
iterator_start(i_base);
sub_iter;
iterator_stop(i_base);
end;
var
q: tn_set;
begin
for_in(q, [1..5, 7..10]);
ITERATE; while ITERATING do begin
SYSTEM.write(q,' ');
end;
end.
]]>