callec

Call with escape-continuation



: \*	['] \  execute ; immediate
: \**	['] \  execute ; immediate

\** callec.fs    Call with Escape-Continuation.
\**
\**      Author: Ouatu Bogdan Ionut. ("humptydumpty")
\**      Published under Public Domain License.
\**
\**      Based on assumption:  Inside a colon-definition,
\**      the address pointed by return-stack pointer contains
\**      continuation of current colon-definition.
\**
\**	 It is a light-weight approach, when CATCH THROW would be
\**      to heavy to use.
\**      
\**      Also, is easier to test in isolation words that accepts
\**	 an XT on top of stack (a-la "Continuation Passing Style"),
\**	 than words that directly drops continuations from return-stack.
\**
\**		USES Gforth specific words:
\**
\**		RP@  ( -- a)  ;fetch return stack pointer
\**		RP!  ( a --)  ;store return stack pointer
\**
\**		For other Forth implementation, please use
\**		their equivalents.
\**
\**		PROVIDES word:
\**
\**             CALL/EC:     \* "name" --     ;at interpret-time
\**                          \* xt-client --  ;at run-time
\**
\**                     create an 'escape to continuation' for 'xt-client'
\**			'xt-client' has stack effect ( ? xt-escape -- ?? )
\**                     'xt-escape' restore continuation of 'NAME'
\**                                 inside a colon definition.
\**		USE like:
\**                     : client ( .. xt -- ... ) .... ;
\**                                 CALL/EC: ESCC
\**                     : word .. ['] client ESCC ... ;
\**
\**                     continuation point could be reused, but beware
\**			case of nested call/ec with different points
\**			of continuations.
\*

         VARIABLE RP_BACKUP
	 
: (restore/ec)  \*  -- xt
  	 ALIGN HERE RP_BACKUP !
	 0 ,  :noname  RP_BACKUP @  ]] LITERAL @ RP! ; [[
;
: CALL/EC:	\*  "name" --  ; new call/ec point
         (restore/ec)
         CREATE	, RP_BACKUP @ ,
	 DOES>  \*  xt-client a --
	 	RP@ over cell+ @ !
		@ swap execute
;

0 [IF]
\ Examples

\*
\* Sam Falvo II DItI pattern: 
\*
\* <quote https://sam-falvo.github.io/2010/02/27/declarative-imperative-then-inquisitive>
\* Examples
\*
\* To help illustrate this pattern, we consider the relatively simple task
\* of tracking a text input cursor on the screen. Consider a 640x480 pixel
\* display, with an 8-pixel fixed-width, 8-pixel tall font. This yields a
\* character matrix 80 columns wide, 60 rows tall on the screen.
\* </quote>

	VARIABLE cx
	VARIABLE cy
	
: scrolledUp ;

\*
\* Original code
\* 
\* : b-edge?   cy @ 59 = ;
\* : -scroll   b-edge? if scrolledUp r> r> 2drop then ;
\* : r-edge?   cx @ 79 = ;
\* : -wrap     r-edge? if 0 cx !  -scroll 1 cy +!  r> drop then ;
\* : bumped    -wrap   1 cx +! ;
\*
\* Would became using CALL/EC:
\* ( To make only minor modifications to original,
\*   I'll  drop 'xt-esc' only when returning to continuation. )
\*

: b-edge?   cy @ 59 = ;
: -scroll   b-edge? if scrolledUp dup execute then ;
: r-edge?   cx @ 79 = ;
: -wrap     r-edge? if 0 cx !  -scroll 1 cy +! dup execute then ;
: bumped    -wrap   1 cx +! ;

        CALL/EC: WITH
	
: with-cursor
            WITH     ( ..xt-esc  ;what happens if executed, not dropped? {:-)
	       drop  ( and so ... )
;
' bumped with-cursor

\* Testing words in isolation:

:noname ."  : "cx ? cy ? cr ;  constant INS ( PECT)

cr ." Inspect '-scroll'"
cr ." -->"  0 cx !  0 cy !  INS -scroll execute clearstack
cr ." -->"  0 cx ! 59 cy !  INS -scroll execute clearstack

cr ." Inspect '-wrap'"
cr ." -->"  0 cx !  0 cy !  INS -wrap execute clearstack
cr ." -->"  0 cx ! 59 cy !  INS -wrap execute clearstack
cr ." -->" 79 cx ! 59 cy !  INS -wrap execute clearstack
cr ." -->" 79 cx !  0 cy !  INS -wrap execute clearstack


\* Little more entangled example  :)

: restore-xt-esc              \* xt-cc -- xt-esc
               >BODY  dup @   \ a xt
	       CREATE swap , ,
	       DOES>  2@ !
;
	CALL/EC: LC  ' LC restore-xt-esc LC-rescue

: YX	 \*  xt0 xt1 -- xt2
	 >R >R :noname R> compile, R> ]] LITERAL ; [[
;
: gradually      \* xt-cli -- f
          LC     \* f
          dup
          IF  LC-rescue
	  ELSE
	      ['] LC >BODY ['] noop 
	      over @ YX swap !       \ overwrite xt-esc!
	  THEN
;
: zzzz   \* xt-resc -- f
     0 swap
     1 . execute
     2 . execute
     3 . execute
     4 . 2drop -1
;
:noname BEGIN cr ['] zzzz gradually .s UNTIL ;
    EXECUTE cr .s cr

[THEN]

by humptydumpty

avatar of humptydumpty

Versions

0.0.2, 0.0.1

Download current as zip

Tags

publicdomain

Dependencies

None

Dependents

None