[fpc-pascal] Portable coroutines

[Mark Morgan Lloyd]

Marco van de Voort wrote:
> In our previous episode, Mark Morgan Lloyd said:
>> Efficient implementation of coroutines requires CPU-specific code in the 
>> RTL and possibly the compiler. However 
>> http://www.chiark.greenend.org.uk/~sgtatham/coroutines.html suggests a 
>> way that coroutines can be implemented in a portable fashion in C, how 
>> can this be done in Object Pascal?
> 
> Seems more an oddity than a system, but it relies heavily on preprocessor
> and fallthrough case.
> 
> The preprocessor part can be done, just use whatever preprocessor
> (maybe even cpp) and then haul the resulting code through fpc.
> 
> But there is no fallthrough case (and personally I think that is a good
> thing)

Generally agreed. I'm not particularly bothered about the syntax, 
although obviously having it fairly compact would be an advantage. I 
don't think it's possible to use a case/goto arrangement since this 
wouldn't be happy jumping into repeat or while loops, but it does look 
as though it's possible to use LongJmp() (insomnia has its advantages):


program coroutines;

uses SysUtils;

type    TState= record
            env: jmp_buf;
            line: cardinal
         end;

var     state: TState;
         once: boolean= false;
         scratch: char;


   function getchar(): char;

   var   sanity: jmp_buf;

   begin

     // Check that we're not trying to jump into exception blocks etc.

     if state.line <> 0 then begin
       SetJmp(sanity);
       Assert(PtrUInt(state.env.sp) + PtrUInt(state.env.bp) =
                 PtrUInt(sanity.sp) + PtrUInt(sanity.bp),
                 'Bad SP or BP at xfer to line ' + IntToStr(state.line));
       LongJmp(state.env, 1)
     end;

     SetJmp(state.env);
     if state.line = 0 then begin
       state.line := StrToInt( (*$I %LINE% *) );
       exit('A')
     end else
       state.line := 0;

..

     repeat
       SetJmp(state.env);
       if state.line = 0 then begin
         state.line := StrToInt( (*$I %LINE% *) );
         exit(#$ff)
       end else
         state.line := 0;
       once := true
     until once
   end { getChar } ;


begin
   FillByte(state, SizeOf(state), 0);
   scratch := getChar();
   while scratch <> #$ff do begin
     WriteLn(scratch);
     scratch := getChar()
   end
end.


The sanity check at the start is obviously processor-specific, but it 
doesn't use anything hidden and can at a pinch be omitted. It's 
obviously excessively verbose, but it is comparatively regular and does 
appear to handle at least some loop types properly.

-- 
Mark Morgan Lloyd
markMLl .AT. telemetry.co .DOT. uk

[Opinions above are the author's, not those of his employers or colleagues]